Compare commits

..

64 Commits

Author SHA1 Message Date
r-zakarya e4930f448b docs(apk): recherche prete, retour apres copie, grace de 2 min, bouton 2FA
Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
2026-09-18 15:03:58 +01:00
r-zakarya 0e32a51bf1 feat(apk): bouton de copie du code 2FA sur chaque ligne de la liste
Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
2026-09-18 14:58:09 +01:00
r-zakarya 255d685e73 fix(apk): 2 min de grace apres une copie, retour automatique decoche par defaut
Android ne laisse pas choisir l'app qui passe devant : moveTaskToBack
ramenait souvent l'ecran d'accueil. Le coffre se reverrouillait aussi
apres 30 s, avant qu'on revienne chercher le mot de passe.

Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
2026-09-18 14:48:23 +01:00
r-zakarya f99fb90ed8 fix(apk): compilation des reglages Copy and search (declarations et TPath de System.IOUtils)
Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
2026-09-18 14:35:45 +01:00
r-zakarya f7ad65c02d feat(apk): Settings -> Copy and search, deux cases pour le retour apres copie et le clavier sur la recherche
Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
2026-09-18 14:33:18 +01:00
r-zakarya 946880ecf4 feat(apk): copier renvoie a l'app d'avant, recherche prete a l'ouverture et au retour
Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
2026-09-18 14:28:52 +01:00
r-zakarya 9a09cc5d29 feat: survol a l'accent sur la barrette, grande fleche de retour dans l'APK
Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
2026-09-18 14:16:45 +01:00
r-zakarya 95c308107c fix(apk): Save enregistre l'URL et le jeton tout de suite, sans attendre un telechargement
Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
2026-09-18 12:36:22 +01:00
r-zakarya a9640ab48f fix(apk): la release ne preremplit plus l'adresse du depot de l'auteur
Verifie : ni la bibliotheque release ni l'exe PC ne contiennent plus
ai-agents4you.

Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
2026-09-18 12:29:27 +01:00
r-zakarya 4555a791b5 fix(apk): plus d'ecran bleu apres le premier scan (la vue web reste masquee apres l'autorisation camera)
Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
2026-09-18 12:22:13 +01:00
r-zakarya d310b2004f fix(apk): coffre ferme, le champ du mot de passe de synchro dit qu'il est range dans le coffre
Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
2026-09-18 12:12:47 +01:00
r-zakarya 119b493a43 fix(apk): le message d'erreur des reglages est bien rouge
Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
2026-09-18 12:04:47 +01:00
r-zakarya 05fc75e8f8 fix(apk): un faux mot de passe de synchro n'ouvre plus le depot, et il se verifie a l'enregistrement
- OpenContainer reutilisait la cle de l'ancien mot de passe : jamais tant
  qu'un nouveau n'est pas verifie
- un essai rate vidait FKey (parametres out TBytes) : derivation dans des
  locales, rangee seulement apres succes
- Save coffre ouvert : verification immediate (DoSync), le bon mot de passe
  est range dans le coffre scelle ; coffre ferme, le champ est grise

Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
2026-09-18 11:51:02 +01:00
r-zakarya ac97d6c207 docs: reglages de la barrette, GitHub et depot prive, erreurs et mot de passe de synchro sur le telephone
Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
2026-09-18 11:39:32 +01:00
r-zakarya 395d7a70d4 fix(apk): un mot de passe de synchro change est verifie contre le depot avant toute publication
Le sha inchange faisait repondre 'rien n'a change' sans dechiffrer : un
mot de passe faux passait pour bon. Tant qu'il n'est pas verifie, le depot
est retelecharge en entier ; la synchro reprend ensuite si rien n'echoue.

Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
2026-09-18 11:38:30 +01:00
r-zakarya 891abf7a9d fix(fillbar): l'onglet Fill bar se met a jour quand la barrette change par clic droit ou par le tray
Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
2026-09-18 11:19:00 +01:00
r-zakarya ba06d4584e feat(fillbar): bouton Settings sur la barrette (icone roue ou texte), reglable comme les autres
Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
2026-09-18 11:14:41 +01:00
r-zakarya c809f4e4c5 fix(apk): le mot de passe de synchro enregistre dans les reglages n'est plus ecrase par celui du cache
Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
2026-09-18 11:13:24 +01:00
r-zakarya 9947ce5718 feat(fillbar): Fill bar settings... au clic droit, ouvre l'onglet par-dessus l'entree en cours
Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
2026-09-18 11:08:52 +01:00
r-zakarya af6e8a2d9a feat(apk): Save des reglages actif seulement s'il y a un changement, coche apres enregistrement
Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
2026-09-18 10:59:03 +01:00
r-zakarya 3c16b41714 feat(sync): GitHub en plus de Gitea, et refus d'un depot public
GitHub parle la meme API des contenus (base64, sha, corps du PUT) : meme
chemin, reconnu a api.github.com/repos/. User-Agent pose partout (GitHub
refuse sans). Un depot public est refuse avant toute lecture ou ecriture,
Gitea comme GitHub : l'historique garde tous les instantanes chiffres.
Telephone : github.com/O/R se convertit en URL d'API et inversement.

Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
2026-09-18 10:36:18 +01:00
r-zakarya d7a8b4ddff feat(fillbar): onglet Fill bar dans les reglages, icones ou texte, boutons Add et Search
- boutons choisis (Full, Password, 2FA, Add current window, Search, Open),
  style icones (Segoe MDL2 Assets) ou texte, opacite au repos, allumee ou non
- clic droit sur la barrette : Show icons / Show text en plus de l'opacite
- info-bulles sur chaque bouton
- Add et Search reprennent les corps extraits de Ctrl+Shift+A et Ctrl+Shift+Q

Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
2026-09-18 10:24:26 +01:00
r-zakarya ba8c4205f9 feat(apk): generateur de mot de passe, erreurs du depot affichees dans les reglages
- de sur le champ mot de passe (nouvelle entree et modification), tirage
  crypto.getRandomValues avec rejet
- Download vault sans reglages ouvre les reglages
- 404/401 tranches (jeton refuse, utilisateur ou depot inexistant, fichier
  absent) et mauvais mot de passe de synchro : les reglages s'ouvrent avec
  le message en rouge

Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
2026-09-18 10:18:47 +01:00
r-zakarya 3eb26e23e5 docs(sync): note l'idee d'un bouton Reinitialiser l'historique, sans la faire
Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
2026-09-17 22:55:18 +01:00
r-zakarya 9b79d62553 fix(apk): l'aide de la synchro s'adapte selon que le coffre est ouvert
Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
2026-09-17 22:34:02 +01:00
r-zakarya 061ea211c0 docs(apk): l'aide de la synchro ne renvoie plus a une section masquee
Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
2026-09-17 22:29:00 +01:00
r-zakarya 034fa48994 docs: QR des reglages, trois facons d'ouvrir, scanner, AllowCreateLocal, debuggable
Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
2026-09-17 22:19:01 +01:00
r-zakarya 405f058a92 fix(apk): le titre Diagnostics disparait avec son bouton en release
Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
2026-09-17 22:08:48 +01:00
r-zakarya 137fa24d19 fix(apk): le libelle du mode d'ouverture suit le scellement apres un telechargement
Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
2026-09-17 21:56:39 +01:00
r-zakarya 451574394e feat(apk): l'app s'appelle Vault, et la release n'est plus debuggable
Delphi ecrivait android:debuggable=true meme en Release : sur un telephone
avec le debogage USB actif, adb run-as ouvrait le dossier prive de l'app.

Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
2026-09-17 21:50:26 +01:00
r-zakarya 1d2ea55bec feat(apk): creer un coffre local seulement en debogage (AllowCreateLocal)
En release le telephone ne sait que reprendre le coffre du depot : l'ecran
d'accueil n'offre plus que Download vault, et RegisterLocal refuse aussi.
Depot vide (404) ou conteneur illisible : rien n'est cree.

Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
2026-09-17 21:14:16 +01:00
r-zakarya 22b1120228 fix(apk): la camera s'affiche des le premier scan apres l'autorisation
Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
2026-09-17 19:05:51 +01:00
r-zakarya c53b3b0b8b chore(apk): retire le diagnostic temporaire du scan QR
Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
2026-09-17 19:01:25 +01:00
r-zakarya fb5d2f35a2 fix(apk): le lien du QR est accepte meme precede d'un caractere invisible
Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
2026-09-17 18:53:14 +01:00
r-zakarya 23967ddfca fix(sync): QR plus court (adresse du depot, sans sur-echappement) + TRY_HARDER au decodage
Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
2026-09-17 18:48:04 +01:00
r-zakarya dd9fd62dcb feat(apk): scanner le QR du poste depuis l'app (ZXing.Delphi, Apache 2.0)
Le scanner du systeme demandait avec quoi ouvrir le lien. L'app ouvre la
camera arriere, decode une image sur quatre et remplit URL + jeton des
qu'un lien pmserver://sync est lu. Rien n'est enregistre avant Save.

Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
2026-09-17 18:38:41 +01:00
r-zakarya 780eecc11b feat(sync): le QR porte un lien pmserver://sync ouvert directement par l'app
Le scanner du telephone envoyait le texte a une recherche web (Google,
Chrome) : le jeton serait parti a un appui pres. Le lien a schema propre
n'a qu'une application pour l'ouvrir. Rien n'est enregistre avant Save.

Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
2026-09-17 18:29:37 +01:00
r-zakarya 9bee179d1b fix(sync): QR a sa vraie taille, la regle svg des icones l'ecrasait
Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
2026-09-17 18:22:33 +01:00
r-zakarya f817a6df43 feat(sync): QR des reglages sur le PC, Paste settings sur le telephone
Le poste genere le QR (DelphiZXingQRCode, Apache 2.0) depuis ses prefs :
URL + jeton, jamais le mot de passe de synchro. Le telephone lit le texte
copie par l'appareil photo et remplit les champs ; Save valide.

Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
2026-09-17 18:03:00 +01:00
r-zakarya 05ff08886d fix(apk): la zone URL prend la hauteur de son texte
Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
2026-09-17 17:42:51 +01:00
r-zakarya 826b0809aa feat(apk): URL du depot affichee en forme courte + sync password quand le coffre vient de la synchro
Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
2026-09-17 17:38:47 +01:00
r-zakarya a9618e9395 fix(apk): URL du depot sur plusieurs lignes, la fin n'etait pas atteignable
Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
2026-09-17 17:33:45 +01:00
r-zakarya 333af8c28f fix(apk): entrer dans un champ place le curseur a la fin du texte
Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
2026-09-17 17:23:25 +01:00
r-zakarya 732b93e5dd feat(apk): URL du depot telle que dans le navigateur + croix qui ne mange plus la fin du champ
Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
2026-09-17 16:23:09 +01:00
r-zakarya 231e3f98ae feat(apk): bouton Save dans les reglages, fermer n'enregistre plus
Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
2026-09-17 16:14:31 +01:00
r-zakarya 8269d99b5b feat(apk): copie de secours au mot de passe, le coffre survit au retrait du schema
Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
2026-09-17 15:13:13 +01:00
r-zakarya d6bf06b6a7 feat(apk): coche sur la facon d'ouvrir en place + journal du mode detecte
Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
2026-09-17 15:02:22 +01:00
r-zakarya 030df48559 fix(apk): Screen lock explique pourquoi il est indisponible au lieu de rester muet
Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
2026-09-17 14:52:49 +01:00
r-zakarya 799f75d53d feat(apk): choisir d'ouvrir avec le verrouillage d'ecran, un code ou le mot de passe du coffre
Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
2026-09-17 14:44:08 +01:00
r-zakarya b6ddd8c2fa docs(licence): essai F bis, login silencieux quand la 2e couche refuse
Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
2026-09-17 06:35:08 +01:00
r-zakarya 649abc85e7 fix(licence): le login n'affiche plus Invalid credentials quand la 2e couche refuse
Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
2026-09-17 06:27:15 +01:00
r-zakarya d41dbfbb3a fix(tray): relancer l'exe ramene bien la fenetre au premier plan
Lancee, fermee par la croix (tray), puis relancee : la fenetre revenait
derriere les autres, seule son icone dans la barre des taches. Mesure :
visible, non minimisee, pas au premier plan.

La 2e instance, qui recoit le double-clic, reveille la 1re par un
message ; mais la 1re n'a recu aucune entree, et Windows lui refuse
SetForegroundWindow. La 2e cede maintenant son droit
(AllowSetForegroundWindow) avant d'envoyer le message.

Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
2026-09-17 06:20:17 +01:00
r-zakarya d8f4f19041 fix(licence): Register ne clignote plus avant d'etre masque
Les onglets etaient visibles par defaut puis masques a la reponse de
/ping : Register restait affiche quelques millisecondes. Ils naissent
maintenant invisibles (visibility, place reservee) et ne sont reveles
qu'une fois la reponse connue — licence valide, ils apparaissent sans
rien decaler ; licence refusee, Register n'est jamais montre.

Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
2026-09-17 06:08:37 +01:00
r-zakarya 510b75d5bf feat(licence): masquer Register quand la 2e couche refuse
A l'arrivee sur l'ecran de connexion, /ping est interroge : son 404 JSON
exact ne peut venir, avant connexion, que de la 2e couche. Dans ce cas les
onglets disparaissent et seul Login reste. Tout autre echec laisse
Register visible — le masquer a tort empecherait un vrai client de creer
son compte. Le test porte sur le corps JSON, pas sur le seul statut : le
verrou du jeton repond aussi 404, sans corps.

Cosmetique : /register etait deja refuse cote serveur. On cesse seulement
de proposer un formulaire qui n'aboutit jamais.

Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
2026-09-17 06:05:50 +01:00
r-zakarya 9de3cde6da fix(licence): le refus de la 2e couche ne s'affiche plus avant connexion
Avant toute session, le 404 generique ne peut venir que de la 2e couche :
les routes appelees a ce stade existent toutes, et leurs vraies erreurs
portent un autre texte. api() vide son message, toast() ignore un message
vide — qui a rapiece la 1re couche ne voit rien.

Apres connexion rien ne change : pieces jointes et dossiers renvoient un
404 'Not found' legitime qu'il faut montrer. Prix assume : une route
perdue par un build casse echouerait aussi en silence avant connexion.

Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
2026-09-17 05:57:16 +01:00
r-zakarya 7582450454 docs(licence): essai F bis, la 2e couche tient depuis l'application
Exe d'essai qui saute l'ecran, licence retiree : toasts « Not found »,
impossible d'entrer. Le 404 est le generique d'une route inexistante,
donc aucun indice qu'une verification de licence existe.

Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
2026-09-17 05:52:58 +01:00
r-zakarya d5234e1390 fix(licence): refus de la 2e couche indiscernable d'une route inconnue
Le 404 a corps vide etait remplace par la page HTML d'Indy, distincte du
404 JSON d'une route inexistante : on pouvait lister les routes reelles.
La 2e couche renvoie maintenant exactement le meme JSON.

Ajoute un exe d'essai qui saute l'ecran d'activation, pour eprouver la
2e couche depuis l'application. Define de compilation
LICENCE_TEST_SKIP_SCREEN, jamais un reglage : un interrupteur dans
config.txt ferait sauter la 1re couche sans rapiecage. Build dedie,
.dcu a part ; verifie que seul l'exe d'essai porte le define.

Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
2026-09-17 05:36:28 +01:00
r-zakarya 16e0f3bd78 docs(licence): essai F, la deuxieme couche tient la premiere sautee
API interrogee en direct, sans passer par l'ecran : licence active /ping
repond pong, licence retiree toutes les routes tombent en 404, y compris
POST /register ; /index.html reste servi.

Notes les deux pieges qui faussaient le resultat — config.txt lu depuis
le dossier courant, et le oui retenu par un processus que fermer la
fenetre ne quitte pas — et une observation : le 404 de la 2e couche
porte la page d'Indy, distincte du 404 JSON d'une route inexistante, ce
qui revele les routes existantes.

Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
2026-09-16 23:50:39 +01:00
r-zakarya f549b36563 fix(android): repack-apk ne depend plus du dossier courant
$p et $outDir etaient relatifs (".\Android64\..."). Lance depuis un
autre dossier que la racine du depot, build-apk compilait bien dans le
depot mais repack empaquetait un dossier inexistant sous le repertoire
courant, y semait des copies de ressources, puis echouait sur un
Copy-Item ("Container cannot be copied onto existing leaf item").

Les deux chemins partent maintenant de $PSScriptRoot. Ca ne se voyait
pas tant que le script etait appele depuis la racine.

Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
2026-09-16 23:31:45 +01:00
r-zakarya a7af9af47e fix(build): lier SQLite dans l'exe, qui chargeait sqlite3.dll du PATH
Sans FireDAC.Phys.SQLiteWrapper.Stat, FireDAC charge sqlite3.dll au
demarrage. Sur ce poste ca marchait quand meme : le dossier bin
d'Embarcadero, qui en contient un, est dans le PATH. Sur une machine
sans Delphi, l'exe refusait de demarrer.

C'est le Win64 qui l'a revele — la DLL du PATH est 32 bits — mais le
Win32 livre etait casse de la meme facon chez quiconque n'a pas Delphi,
paquet prepare pour un tiers compris.

Prouve avec un PATH reduit a Windows : avec l'unite SQLite s'ouvre
(3.42.0), sans elle l'erreur exacte. Lire la table d'import ne
suffisait pas, le chargement est dynamique.

Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
2026-09-16 23:15:42 +01:00
r-zakarya 0d4d4d518c build: activer Win64, dont la configuration etait vide
Le groupe Base_Win64 du .dproj n'avait ni prefixes d'unites — d'ou
"Unite 'Windows' non trouvee" en recompilant TMS — ni Cfg_1_Win64 :
l'exe aurait compile sans icone et sans PerMonitorV2, donc flou sur un
ecran haute resolution. Complete en miroir exact de Win32, et Win64
coche dans l'IDE.

Builds Release 32 et 64 bits produits sur E:, un dossier .dcu par
plateforme — c'est ce qui empeche la pollution des sources TMS qui avait
casse le build Win32 le 7 septembre. Verifie : aucun .dcu depose.

Empreinte de licence identique en 32 et 64 bits, les deux couches a
TRUE des deux cotes : une licence vaut pour les deux exe.

Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
2026-09-16 23:01:25 +01:00
r-zakarya 72b776c26e docs: le dernier caractere de controle, que le commit precedent disait absent
\a s'etait change en BEL dans E:\a pmanager. Le commit precedent
affirmait qu'il ne restait plus rien sans l'avoir mesure apres coup —
c'est ce qui l'a laisse passer. Mesure cette fois : zero.

Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
2026-09-16 22:56:44 +01:00
r-zakarya 5d51614a1b docs: reparer deux chemins que le heredoc avait corrompus
\t et \r s'etaient changes en tabulation et en retour chariot dans les
chemins du piege TMS. Verifie apres coup : plus aucun caractere de
controle parasite dans le fichier.

Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
2026-09-16 22:56:23 +01:00
r-zakarya 1fa5113c02 feat(licence): deuxieme couche, l'API refuse sans licence valable
L'ecran d'activation ne consultait qu'un branchement : le rapiecer
ouvrait tout, l'API ne demandant rien. Chaque route de PM.Router passe
maintenant par PM.LicenceGate.ApiLicenceOk avant son handler.

Aucune fonction de decision partagee avec PM.Licence — sinon un seul
rapiecage ouvrirait les deux couches. La verification est refaite de
bout en bout, appels CNG redeclares compris ; seules la cle publique et
le nom de la pref sont partages, parce que ce sont des donnees.

Branchee dans DispatchRequest : les fichiers de l'ecran d'activation
passent par TryServeEmbedded, non garde, sinon l'ecran ne se chargerait
plus. Un oui est retenu pour le processus, un non jamais.

Le risque etait qu'elle refuse un client licencie. Auto-test sur un
vecteur lie a une empreinte fixe, sens accepte en premier ; et accord
verifie en conditions reelles sur ce poste : IsLicensed = TRUE,
ApiLicenceOk = TRUE.

Documente aussi le piege du jour, sans lien avec ce code : des .dcu TMS
x64 deposes a cote des sources cassaient le build Win32, et la sortie
redirigee vers E: faute de place sur Z:.

Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
2026-09-16 22:55:33 +01:00
105 changed files with 28307 additions and 166 deletions
+11
View File
@@ -31,6 +31,9 @@
BiometricPrompt n'existe pas encore. --> BiometricPrompt n'existe pas encore. -->
<uses-permission android:name="android.permission.USE_BIOMETRIC" /> <uses-permission android:name="android.permission.USE_BIOMETRIC" />
<uses-permission android:name="android.permission.USE_FINGERPRINT" /> <uses-permission android:name="android.permission.USE_FINGERPRINT" />
<!-- Scanner du QR des reglages de synchro, demandee au premier appui. -->
<uses-permission android:name="android.permission.CAMERA" />
<uses-feature android:name="android.hardware.camera" android:required="false" />
<uses-feature android:glEsVersion="0x00020000" android:required="true"/> <uses-feature android:glEsVersion="0x00020000" android:required="true"/>
<queries> <queries>
<%queries-child-elements%> <%queries-child-elements%>
@@ -93,6 +96,14 @@
<category android:name="android.intent.category.LAUNCHER" /> <category android:name="android.intent.category.LAUNCHER" />
</intent-filter> </intent-filter>
<!-- Lien pmserver://sync?u=&t= du QR affiche par le poste : le
scanner du telephone l'ouvre directement dans l'app. -->
<intent-filter>
<action android:name="android.intent.action.VIEW" />
<category android:name="android.intent.category.DEFAULT" />
<category android:name="android.intent.category.BROWSABLE" />
<data android:scheme="pmserver" android:host="sync" />
</intent-filter>
</activity> </activity>
<!-- FMX n'affiche pas BiometricPrompt depuis notre NativeActivity : il <!-- FMX n'affiche pas BiometricPrompt depuis notre NativeActivity : il
lance SA PROPRE activite, qui heberge le fragment androidx. Elle lance SA PROPRE activite, qui heberge le fragment androidx. Elle
+219
View File
@@ -283,6 +283,38 @@ Détails :
Le cadre est peint dans `WM_ERASEBKGND` plutôt que par `WS_BORDER`, qui se Le cadre est peint dans `WM_ERASEBKGND` plutôt que par `WS_BORDER`, qui se
sert dans les couleurs système. sert dans les couleurs système.
### Réglages de la barrette (2026-09-18)
**Settings → onglet Fill bar**, et le **clic droit** sur la barrette pour les
mêmes choix au plus court.
- **Boutons au choix** (`lazyButtons`, liste ordonnée) : Full, Password, 2FA,
**Add** (= `Ctrl+Shift+A`, nouvelle entrée depuis la fenêtre en avant),
**Search** (= `Ctrl+Shift+Q`), Open, **Settings** (ouvre cet onglet). Le `X`
est toujours là. `'none'` = aucun bouton choisi (liste vide ≠ liste par défaut).
Add et Search appellent **les mêmes corps que les raccourcis**, extraits en
`FireNewEntryRequest` / `FireQuickSearchRequest` — une seule capture de la
fenêtre cible, deux gestes. `NOACTIVATE` les rend justes : la fenêtre en avant
au clic est bien celle de l'utilisateur.
- **Icônes ou texte** (`lazyIcons`) : glyphes de la police **Segoe MDL2 Assets**
(Windows 10/11), rien à embarquer, couleur du thème comme un mot. Info-bulles
(`TOOLTIPS_CLASS`, `TTS_ALWAYSTIP` car la barrette n'est jamais active) sur
chaque bouton, dans les deux modes. **La largeur de la barrette se calcule**
(`FLazyW`) : elle dépend des boutons et du mode.
- **Tout en prefs DPAPI**, pas dans `settings_json` : la barrette s'allume coffre
fermé. Pont : `fillbar/get` → `Bridge.onFillBar({on,buttons,icons,alpha})`,
`fillbar/set?on=&buttons=&icons=&alpha=`. Rien de secret dedans.
- **Reconstruire = `ReloadLazyBar`, POSTÉ** (`WM_LAZY_RELOAD`) : le clic droit
vient de la barrette, qu'on ne détruit pas depuis son propre gestionnaire
(même raison que le `X`).
- **L'onglet suit la barrette** : un changement par clic droit ou par le menu du
tray déclenche `OnFillBarChanged` → la page relit `fillbar/get`. Gardé par
`FBrowserInitialized` : `RestoreLazyBar` passe par là au démarrage.
- **Settings depuis la barrette** (bouton ou clic droit → *Fill bar
settings...*) : la fenêtre revient, puis les réglages s'ouvrent **par-dessus**
une entrée en cours d'édition, qui reste intacte dessous (Échap ferme d'abord
les réglages). Coffre verrouillé : message, pas de réglages.
## Licences (`PM.Licence`) ## Licences (`PM.Licence`)
Verification **hors ligne** d'une licence signee ECDSA P-256. Une licence est Verification **hors ligne** d'une licence signee ECDSA P-256. Une licence est
@@ -459,6 +491,69 @@ en dix minutes serait le mauvais echange. Le but est de tenir le mobile attache
a un poste paye, pas de resister a une attaque — l'APK ne peut pas resister, et a un poste paye, pas de resister a une attaque — l'APK ne peut pas resister, et
faire semblant couterait plus que de l'admettre. faire semblant couterait plus que de l'admettre.
**Le reste du travail Android est dans
[android-client/README.md](android-client/README.md)**, tenu a jour le
2026-09-17 : les trois facons d'ouvrir le coffre (verrouillage d'ecran, code
d'application, mot de passe), la copie de secours `vault-recover.bin` qui
survit au schema retire, le scanner de QR (`ThirdParty/ZXing`), le define
`AllowCreateLocal` — creer un coffre sur le telephone est reserve au debogage —
et le correctif du manifeste, dont l'APK **release n'est plus `debuggable`**.
### Deuxieme couche : l'API refuse sans licence (`PM.LicenceGate`)
La premiere couche (l'ecran d'activation) ne consultait qu'un branchement,
`IsLicensed` ; le rapiecer ouvrait tout, l'API ne demandant rien. **Chaque route
de `PM.Router` passe maintenant par `ApiLicenceOk` avant son handler** — sauter
l'ecran ne donne plus acces aux donnees.
- **Aucune fonction de decision partagee avec `PM.Licence`.** Si les deux
couches appelaient `IsLicensed`, un seul rapiecage les ouvrirait toutes les
deux. `PM.LicenceGate` refait sa propre verification de bout en bout —
decodage, SHA-256, appels CNG **redeclares sous d'autres noms**, lecture du
champ `m` — et ne prend a `PM.Licence` que des **donnees** : la cle publique
(`LicencePublicKey`) et le nom de la pref (`LicencePrefKey`).
- **Branchee dans `DispatchRequest`, pas avant.** Seules les routes de l'API
atteignent ce point ; les fichiers de l'ecran d'activation passent par
`TryServeEmbedded`, non garde — sinon l'ecran qui permet de s'activer ne se
chargerait plus. **404**, pas 403, comme le reste du verrouillage.
- **Le refus est le MEME 404 qu'une route inexistante** (`TJSONHelper.SendError(404,
'Not found')`). Un corps vide ne suffisait pas : Indy le remplace par sa page
HTML, distincte du JSON d'une route inconnue — ce qui revelait les routes
existantes (vu a l'essai F de LICENCE-TESTS.md).
- **Exe d'essai qui saute l'ecran** : define `LICENCE_TEST_SKIP_SCREEN`, qui fait
repondre `licence/status` ok. **A la compilation et jamais par un reglage** —
un interrupteur dans `config.txt`, que n'importe qui cree a cote de l'exe,
ferait sauter la 1re couche sans rapiecage. Build dedie, dossiers exe ET
`.dcu` a part (des unites compilees avec ce define ne doivent jamais etre
liees dans un exe normal) ; `;` des defines echappe en `%3B` pour MSBuild :
```
msbuild PMServer.dproj /p:Config=Release /p:Platform=Win32
"/p:DCC_Define=RELEASE%3BLICENCE_TEST_SKIP_SCREEN"
"/p:DCC_ExeOutput=E:\password manager\Win32-TEST-licence"
"/p:DCC_DcuOutput=E:\password manager\dcu\Win32-TEST-licence"
```
Verifier apres build : la chaine `LICENCE TEST BUILD` (UTF-16) ne doit
exister que dans l'exe d'essai.
- Un **oui** est retenu pour le processus (le test est sur le chemin de chaque
requete) ; un **non** jamais, pour qu'une activation faite juste avant soit
vue a la requete suivante.
- **Le prix de l'independance : deux implementations qui doivent dire la meme
chose.** Une divergence ferait passer l'ecran puis tomber chaque requete en
404 — refuser quelqu'un qui a paye. `SelfTestLicenceGate` eprouve la 2e couche
seule sur un vecteur lie a une empreinte fixe (`0123456789abcdef`, paire
jetable dont la privee n'a jamais ete ecrite), **en commencant par le sens qui
accepte**. L'**accord** entre couches ne se teste pas en vecteur — la 1re
compare a l'empreinte reelle du poste — et se prouve en conditions reelles :
au 2026-09-16, sur ce poste avec la vraie licence, `IsLicensed` = TRUE et
`ApiLicenceOk` = TRUE.
- **Ce que ca n'arrete pas** : quelqu'un qui trouve et rapiece les deux. Une
heure devient deux ; la nature d'un schema hors ligne ne change pas. Les
protections du commerce (VMProtect, Themida) iraient plus loin mais
declenchent des **faux positifs antivirus** — ruineux pour un gestionnaire de
mots de passe. Les outils libres ne s'appliquent pas : OLLVM exige un
compilateur LLVM (dcc32 Win32 n'en est pas un), Alcatraz est x64 seulement,
UPX se defait par `upx -d`.
**ORDRE OBLIGATOIRE.** Tant que `LicencePublicKeyBlob` est a zero, aucune **ORDRE OBLIGATOIRE.** Tant que `LicencePublicKeyBlob` est a zero, aucune
licence n'est valide et l'ecran d'activation est **infranchissable** — l'exe licence n'est valide et l'ecran d'activation est **infranchissable** — l'exe
construit ne s'ouvre plus. Poser la cle publique AVANT de deployer : construit ne s'ouvre plus. Poser la cle publique AVANT de deployer :
@@ -992,6 +1087,81 @@ device, never transmitted.
Sensitive actions (export, change master pw, recovery code…) still Sensitive actions (export, change master pw, recovery code…) still
require master pw via `askReauth` — sync never substitutes. require master pw via `askReauth` — sync never substitutes.
### QR des reglages pour le telephone (`sync/qr`)
Recopier une URL d'API et quarante caracteres de jeton sur un telephone est le
vrai obstacle a l'installation. **Settings -> Sync -> QR for phone** affiche un
QR que l'application Android scanne elle-meme.
- **C'est l'EXE qui fabrique le QR**, pas la page : il lit `syncUrl` et
`syncPwd` dans ses prefs DPAPI et n'envoie a la page que la **matrice**
noir/blanc (`Bridge.onSyncQr(taille, bits)`). Le jeton ne traverse donc pas le
moteur de rendu en clair - meme regle que `prefs/has`.
- **Le mot de passe de synchro n'y est JAMAIS** : un QR se photographie
par-dessus l'epaule, et avec lui il ouvrirait le coffre du depot. Il se tape
une fois sur le telephone. Le QR se masque seul au bout de 60 s.
- **Le contenu est un lien `pmserver://sync?u=&t=`, pas du texte.** L'appareil
photo du telephone envoie tout TEXTE a une recherche web : le jeton serait
parti chez Google a un appui pres. Un schema propre n'a qu'une application
pour l'ouvrir.
- **Le plus court possible** : l'adresse du depot (`https://hote/Owner/Repo`) et
non l'URL d'API - le telephone la rallonge a l'enregistrement -, et seuls
`% & # + espace` sont echappes. `TNetEncoding.URL.Encode` changeait chaque
`:` et `/` en trois caracteres, et le QR devenait trop dense pour etre lu.
- Generateur : **`Source/DelphiZXingQRCode.pas`** (portage ZXing, Apache 2.0,
licence a cote). `BCryptVerifySignature` n'a rien a voir ici : le QR n'est pas
signe, il ne porte que ce que l'utilisateur voit deja a l'ecran.
- **Piege CSS rencontre** : `css/style.css` impose `svg { width: 16px }` a
toutes les icones, ce qui reduisait le QR a la taille d'une icone. La taille
est donc posee **en style direct** sur le `<svg>`.
### GitHub, et refus d'un depot public (2026-09-18)
- **GitHub parle la meme API des contenus que Gitea** (contenu base64, `sha`,
meme corps de PUT) : meme chemin, reconnu a `api.github.com/repos/` en plus de
`/api/v1/repos/`. `syncIsGitea` (JS), `LGitea` (UMainForm) et
`TSyncClient.IsGitea` (APK) reconnaissent les deux.
- **`User-Agent: PMServer` partout** : GitHub rend 403 a une requete sans ;
Gitea l'ignore.
- **Un depot PUBLIC est refuse**, Gitea comme GitHub, avant toute lecture ou
ecriture : `GET` du depot (URL des contenus coupee a `/contents/`), champ
`private`. Chaque synchro est un commit, l'historique garde tous les
instantanes chiffres ; public, n'importe qui les attaque hors ligne. Un doute
reseau ne bloque pas (pas de verdict = on laisse la vraie requete parler).
- **Limite GitHub** : au-dela de 1 Mo, l'API des contenus ne rend plus le fichier
(`encoding: none`). Le coffre chiffre fait ~250 Ko au 2026-09-18.
- Telephone : `https://github.com/O/R` <-> URL d'API, comme pour Gitea. Le QR
du PC porte aussi la forme courte `github.com/O/R`.
### Idee gardee : « Reinitialiser l'historique » du depot de synchro
**Rien n'est fait, et le code actuel reste tel quel** (decide le 2026-09-17).
Chaque synchro est un commit, donc le depot garde TOUS les instantanes
precedents. Ca ne coute rien en place (Git ne stocke que les differences,
86 commits au 2026-09-17), mais **apres un changement de mot de passe de
synchro les anciens restent dechiffrables avec l'ancien** - c'est la seule
raison de vouloir les couper.
- **L'application ne peut pas le faire par l'API des contenus de Gitea** :
elle sait ajouter un commit, rien d'autre. Supprimer des commits demande
un `git push --force`, donc un client git dans l'exe.
- **Ce qui serait possible par l'API** : `DELETE /repos/…` puis
`POST /user/repos`, puis republier. **Ecarte en automatique** : entre les
deux, le depot ne contient plus rien - une coupure reseau la et la copie
distante est perdue -, et le jeton devrait porter le droit de supprimer un
depot, ce qui en fait une bien plus grosse prise s'il fuit.
- **La forme retenue le jour ou on le fera** : un bouton
« Reinitialiser l'historique » dans Settings -> Sync, avec confirmation,
jamais a chaque synchro.
- **En attendant**, la commande manuelle sur un clone, apres une rotation du
mot de passe de synchro :
```
git checkout --orphan tronque HEAD~10 && git commit -m "historique tronque"
git rebase --onto tronque HEAD~10 main && git push --force origin main
```
Sans danger pour les appareils : Gitea identifie le fichier par le hachage
de son **contenu**, que la reecriture d'historique ne change pas.
**Tombstone purge on (re)create** : `POST /entries` and **Tombstone purge on (re)create** : `POST /entries` and
`POST /entries/bulk-import` both DELETE any `entry_tombstones` row `POST /entries/bulk-import` both DELETE any `entry_tombstones` row
matching the inserted uuid (same transaction). Without this, restoring matching the inserted uuid (same transaction). Without this, restoring
@@ -1375,6 +1545,55 @@ le vide ET vide `FPendingURL` → écran noir permanent sur cold-start lent.
fix port-fixe est possible (`port=N` dans `config.txt`) mais on perd fix port-fixe est possible (`port=N` dans `config.txt`) mais on perd
l'aléatoire qui complique le scan externe. l'aléatoire qui complique le scan externe.
- **Modifier les `Enable*` props TMS en `OnInitialized`**, pas FormCreate. - **Modifier les `Enable*` props TMS en `OnInitialized`**, pas FormCreate.
- **`F2048 Bad unit format … FMX.TMSFNC*.dcu … Found x64`** : le dossier des
sources `…\tmssoftware\registered\TMS FNC Core\` est dans le chemin de
recherche, et une compilation y depose ses `.dcu` **a cote des `.pas`**. Une
compilation **Win64** (le 2026-09-07 a 11 h 45) en a reecrit 33 en x64, et le
build Win32 buttait dessus — **sans aucun rapport avec le code du projet** :
l'arbre propre echouait a l'identique. Correctif : les deplacer
(sauvegarde dans `…\tmssoftware\_backup-x64-dcu-2026-09-07`) ; le build Win32
retombe sur `Delphi12\Win32\Release\`. Le symptome reviendra a chaque
alternance Win32/Win64 sur ce poste.
- **Z: est quasi plein (0,3 Go au 2026-09-16).** Le build sort sur `E:\password manager\`,
**un dossier par plateforme** — exe ET `.dcu` :
```
msbuild PMServer.dproj /t:Build /p:Config=Release /p:Platform=Win32|Win64
"/p:DCC_ExeOutput=E:\password manager\<Plateforme>"
"/p:DCC_DcuOutput=E:\password manager\dcu\<Plateforme>"
```
Surcharge MSBuild, pas dans le `.dproj` : un chemin propre a une machine n'a
pas sa place dans un fichier versionne. **F9 dans l'IDE sort toujours sur Z:.**
**La sortie Android suit le meme chemin** : `Z:\password-manager\Android64` est
une **jonction** vers `E:\password manager\Android64`, posee le 2026-09-17 quand
`Z:` est tombe a 40 Ko libres et que `aapt` echouait sans dire pourquoi.
**Des `.dcu` separes par plateforme sont ce qui empeche la pollution TMS**
ci-dessus : verifie au premier build 32+64, aucun `.dcu` depose a cote des
sources TMS. L'exe de `E:\password manager\` cree **son propre `vault.db`** a
cote de lui, sans `config.txt` : ni le coffre de `delphi-backend\`, ni celui
de `E:\a pmanager\`.
- **SQLite doit etre LIE dans l'exe : `FireDAC.Phys.SQLiteWrapper.Stat` dans
`PM.Database`.** Sans cette unite, FireDAC **charge `sqlite3.dll`** au
demarrage. Le piege : **sur un poste de developpement ca marche quand meme**,
parce que `…\Embarcadero\Studio\23.0\bin\sqlite3.dll` est dans le PATH. On
croit donc livrer un exe autonome ; sur une machine sans Delphi il refuse de
demarrer (`[FireDAC][Phys][SQLite]-314 Cannot load vendor library`). C'est
le Win64 qui l'a revele — la DLL du PATH est 32 bits, donc introuvable pour
lui — mais le **Win32 livre jusqu'au 2026-09-16 etait casse de la meme facon**
chez quiconque n'a pas Delphi, y compris le paquet prepare pour un tiers.
Prouve avec un PATH reduit a `C:\Windows\System32;C:\Windows` : avec l'unite
« SQLite OUVERT 3.42.0 », sans elle l'erreur exacte. `Stat` et non `FDEStat` :
le coffre est un SQLite ordinaire, le chiffrement se fait cote JavaScript.
**Pour verifier qu'un exe est vraiment autonome, retirer Delphi du PATH** —
lire la table d'import ne suffit pas, le chargement est dynamique.
- **Win64 (active le 2026-09-16).** Le groupe `Base_Win64` du `.dproj` etait
quasi vide : **ni prefixes d'unites** (`Winapi;System.Win;…`), d'ou
`F2613 Unite 'Windows' non trouvee` en recompilant TMS, **ni `Cfg_1_Win64`**
— l'exe aurait compile sans icone et sans `PerMonitorV2`, donc flou sur un
ecran haute resolution. Complete en miroir exact de Win32. **L'empreinte de
licence est identique en 32 et 64 bits** (verifie : `2179-C42D-2DF2-AE0B`
des deux cotes, les deux couches a TRUE) — une licence vaut pour les deux.
L'exe 64 bits cite `WebView2Loader_x64` : son ouverture reelle reste a
eprouver en le lancant.
## Conventions code (héritage sessions précédentes) ## Conventions code (héritage sessions précédentes)
+69
View File
@@ -161,6 +161,75 @@ Deux observations de la campagne, gardées parce qu'elles se reproduiront :
--- ---
## F. La deuxieme couche, la premiere sautee — 2026-09-16
Ne rien rapiecer : **ignorer l'ecran completement** et interroger l'API en
direct, comme quelqu'un qui aurait saute la 1re couche. Meme requete, licence
active puis retiree.
**Preparation** : `config.txt` a cote de l'exe avec `port=8799`,
`require_token=false`, `require_process_check=false`. Les deux derniers sont
indispensables — sinon le jeton ou le controle de processus repondent 404
AVANT la 2e couche, et l'essai ne prouve rien. **A supprimer ensuite.**
**Deux pieges rencontres, qui fausseraient le resultat :**
- **`config.txt` est lu depuis le dossier courant.** Lancer l'exe d'ailleurs le
prive de sa config : jeton et controle actifs, 404 partout, faux positif.
Lancer avec le dossier de l'exe comme dossier de travail.
- **La 2e couche retient un « oui » pour la vie du processus.** Fermer la
fenetre ne quitte pas (elle part dans la zone de notification) : relance =
reveil de l'ancien processus, qui repond encore `pong`. Quitter par le menu
de l'icone, verifier qu'aucune instance ne tourne, puis relancer.
**Resultat** :
| Requete | Licence active | Licence retiree |
|---|---|---|
| `GET /ping` | 200 `pong` | **404** |
| `GET /entries`, `/settings`, `/folders` | — | **404** |
| `POST /register` | — | **404** — impossible de se creer un compte |
| `GET /index.html` | 200 | **200** — l'ecran d'activation reste servi |
| `GET /nexiste-pas` | 404 JSON | 404 JSON |
**Observation** : le refus de la 2e couche n'a pas un corps vide — Indy remplace
un `ContentText` vide par sa page `404 Not Found`. Il se distingue donc d'une
route inexistante (`{"error":"Not found"}`), ce qui **revele quelles routes
existent**. Sans consequence en production (jeton et controle de processus
actifs), mais contraire au principe du verrouillage.
---
## F bis. Meme essai, depuis l'application — 2026-09-17
L'essai F interrogeait l'API a la main. Celui-ci passe par l'application, avec
un **exe d'essai** compile avec `LICENCE_TEST_SKIP_SCREEN` : la 1re couche
repond toujours « licencie », comme si elle avait ete rapiecee. La 2e couche,
independante, verifie la vraie licence. (Construction : voir CLAUDE.md,
section de la deuxieme couche. Jamais livre.)
1. Lancer l'exe d'essai, licence active : pas d'ecran d'activation, *Register*
d'un compte de test reussit.
2. *Settings → Licence* → **Deactivate (debug)**, puis **Quit** par l'icone.
3. Relancer : toujours pas d'ecran d'activation (1re couche « rapiecee »).
4. Tenter d'entrer.
**Resultat** : toasts rouges **« Not found »**, impossible d'entrer. Le message
est le 404 generique, identique a celui d'une route inexistante — depuis le
correctif du meme jour. Qui aurait rapiece la 1re couche voit une application
qui ne marche pas, **sans indice qu'une verification de licence existe**.
Complement 2026-09-17 : **Login** n'affichait pas rien, mais « Invalid
credentials » (le 404 tombait dans la branche utilisateur inconnu). Corrige
(`649abc8`) ; reteste licence desactivee : aucune bulle. Piege rencontre : avec
la licence encore active, l'exe d'essai ouvre le coffre normalement — la licence
est dans `prefs.bin` du compte Windows, partagee par tous les exe du poste.
**Apres l'essai** : reactiver la licence avec un exe **normal** — l'exe
d'essai n'affiche jamais l'ecran d'activation.
---
## Ce qu'aucun de ces essais ne prouve ## Ce qu'aucun de ces essais ne prouve
À dire clairement, pour ne pas se croire protégé de ce qu'on ne l'est pas : À dire clairement, pour ne pas se croire protégé de ce qu'on ne l'est pas :
+48
View File
@@ -42,6 +42,14 @@ procedure TintSystemBars(ATop, ABottom: TAlphaColor);
/// decide de la suite d'apres la reponse. /// decide de la suite d'apres la reponse.
function HideSoftKeyboard: Boolean; function HideSoftKeyboard: Boolean;
/// Deplie le clavier pour le champ qui a le focus (la recherche). Un focus()
/// JavaScript seul pose le curseur sans ouvrir le clavier.
procedure ShowSoftKeyboard;
/// Renvoie l'application en arriere-plan : on retombe sur l'app d'ou l'on
/// venait, prete a recevoir le collage.
procedure MoveAppToBack;
implementation implementation
{$IF DEFINED(ANDROID)} {$IF DEFINED(ANDROID)}
@@ -126,4 +134,44 @@ begin
end; end;
{$ENDIF} {$ENDIF}
{$IF DEFINED(ANDROID)}
procedure ShowSoftKeyboard;
var
LService: JObject;
LView: JView;
begin
try
LView := TAndroidHelper.Activity.getWindow.getDecorView.findFocus;
if LView = nil then Exit;
LService := TAndroidHelper.Context.getSystemService(
TJContext.JavaClass.INPUT_METHOD_SERVICE);
if LService = nil then Exit;
TJInputMethodManager.Wrap(LService).showSoftInput(LView, 0);
except
// Pas de clavier : la recherche reste a un appui.
end;
end;
procedure MoveAppToBack;
begin
CallInUIThread(
procedure
begin
try
TAndroidHelper.Activity.moveTaskToBack(True);
except
// Reste au premier plan : on colle apres un retour manuel.
end;
end);
end;
{$ELSE}
procedure ShowSoftKeyboard;
begin
end;
procedure MoveAppToBack;
begin
end;
{$ENDIF}
end. end.
+72 -7
View File
@@ -186,6 +186,19 @@ procedure SetPendingFlag(AOn: Boolean);
/// Chemin du fichier, pour le journal et les tests. /// Chemin du fichier, pour le journal et les tests.
function VaultPath: string; function VaultPath: string;
/// COPIE DE SECOURS du cache quand il est scelle par le verrouillage d'ecran.
///
/// Retirer le schema (ou le reinitialiser) fait DETRUIRE par Android la cle qui
/// scelle vault.bin : le coffre devenait illisible et il fallait le
/// retelecharger. SaveVault ecrit donc a cote une seconde copie scellee sous le
/// mot de passe (meme format que le code d'app, VER_PIN : cle de l'appareil
/// sans contrainte + PBKDF2 du mot de passe), que rien dans Android n'invalide.
/// Elle n'existe QUE pour un cache VER_WRAP ; tout autre scellement l'efface.
function HasRecoveryVault: Boolean;
function LoadRecoveryVault(out APlainJson, AETag, ASyncPwd: string;
out AKey, ASalt: TBytes; out AIterations: Integer;
const APwd: string): Boolean;
/// Reglages du serveur : URL et jeton Bearer. /// Reglages du serveur : URL et jeton Bearer.
/// ///
/// FICHIER SEPARE, ET PROTECTION PLUS FAIBLE, DELIBEREMENT. Ils sont chiffres /// FICHIER SEPARE, ET PROTECTION PLUS FAIBLE, DELIBEREMENT. Ils sont chiffres
@@ -218,6 +231,7 @@ const
LOCAL_FILE = 'vault-local.json'; LOCAL_FILE = 'vault-local.json';
PENDING_FILE = 'pending.flag'; PENDING_FILE = 'pending.flag';
SETTINGS_FILE = 'settings.bin'; SETTINGS_FILE = 'settings.bin';
RECOVER_FILE = 'vault-recover.bin';
// Un alias par schema : la contrainte d'authentification est figee a la // Un alias par schema : la contrainte d'authentification est figee a la
// creation de la cle et ne peut pas etre ajoutee apres coup. // creation de la cle et ne peut pas etre ajoutee apres coup.
KEY_ALIAS = 'pm_vault_key'; // AES, sans authentification KEY_ALIAS = 'pm_vault_key'; // AES, sans authentification
@@ -298,12 +312,18 @@ begin
TFile.Delete(LocalContainerPath); TFile.Delete(LocalContainerPath);
end; end;
function RecoverPath: string;
begin
Result := TPath.Combine(TPath.GetHomePath, RECOVER_FILE);
end;
procedure DropLocalVault; procedure DropLocalVault;
begin begin
// Chacun sous son propre try : un fichier absent ou verrouille ne doit pas // Chacun sous son propre try : un fichier absent ou verrouille ne doit pas
// empecher les deux autres de partir - un effacement a moitie fait laisse // empecher les deux autres de partir - un effacement a moitie fait laisse
// l'appareil dans un etat que personne n'a voulu. // l'appareil dans un etat que personne n'a voulu.
try if TFile.Exists(VaultPath) then TFile.Delete(VaultPath); except end; try if TFile.Exists(VaultPath) then TFile.Delete(VaultPath); except end;
try if TFile.Exists(RecoverPath) then TFile.Delete(RecoverPath); except end;
try DropLocalContainer; except end; try DropLocalContainer; except end;
try SetPendingFlag(False); except end; try SetPendingFlag(False); except end;
end; end;
@@ -335,6 +355,11 @@ begin
Result := TPath.Combine(TPath.GetHomePath, VAULT_FILE); Result := TPath.Combine(TPath.GetHomePath, VAULT_FILE);
end; end;
function HasRecoveryVault: Boolean;
begin
Result := TFile.Exists(RecoverPath);
end;
function HasVault: Boolean; function HasVault: Boolean;
begin begin
Result := TFile.Exists(VaultPath); Result := TFile.Exists(VaultPath);
@@ -344,6 +369,8 @@ procedure ClearVault;
begin begin
if TFile.Exists(VaultPath) then if TFile.Exists(VaultPath) then
TFile.Delete(VaultPath); TFile.Delete(VaultPath);
if TFile.Exists(RecoverPath) then
TFile.Delete(RecoverPath);
end; end;
{$IF DEFINED(ANDROID)} {$IF DEFINED(ANDROID)}
@@ -919,7 +946,7 @@ begin
end; end;
end; end;
procedure SaveVault(const APlainJson, AETag, ASyncPwd: string; procedure SaveVaultAt(const APath, APlainJson, AETag, ASyncPwd: string;
ARequireAuth, AFreshKey: Boolean; const APin: string; ARequireAuth, AFreshKey: Boolean; const APin: string;
const AKey, ASalt: TBytes; AIterations: Integer; AClearPin: Boolean); const AKey, ASalt: TBytes; AIterations: Integer; AClearPin: Boolean);
{$IF DEFINED(ANDROID)} {$IF DEFINED(ANDROID)}
@@ -1010,7 +1037,7 @@ begin
LOut[0] := VER_PIN; LOut[0] := VER_PIN;
Move(LIv[0], LOut[1], Length(LIv)); Move(LIv[0], LOut[1], Length(LIv));
Move(LCt[0], LOut[1 + Length(LIv)], Length(LCt)); Move(LCt[0], LOut[1 + Length(LIv)], Length(LCt));
TFile.WriteAllBytes(VaultPath, LOut); TFile.WriteAllBytes(APath, LOut);
Exit; Exit;
end; end;
@@ -1087,7 +1114,7 @@ begin
Move(LCt[0], LOut[1 + Length(LIv)], Length(LCt)); Move(LCt[0], LOut[1 + Length(LIv)], Length(LCt));
end; end;
TFile.WriteAllBytes(VaultPath, LOut); TFile.WriteAllBytes(APath, LOut);
end; end;
{$ELSE} {$ELSE}
begin begin
@@ -1095,9 +1122,30 @@ begin
end; end;
{$ENDIF} {$ENDIF}
function LoadVault(out APlainJson, AETag, ASyncPwd: string; procedure SaveVault(const APlainJson, AETag, ASyncPwd: string;
ARequireAuth, AFreshKey: Boolean; const APin: string;
const AKey, ASalt: TBytes; AIterations: Integer; AClearPin: Boolean);
begin
SaveVaultAt(VaultPath, APlainJson, AETag, ASyncPwd, ARequireAuth, AFreshKey,
APin, AKey, ASalt, AIterations, AClearPin);
// Suit le scellement REEL (lu dans l'en-tete), pas celui demande : un
// appareil sans verrouillage retombe sur VER_PLAIN, et une ecriture refusee
// laisse l'ancien en place.
try
if VaultNeedsAuth and (ASyncPwd <> '') then
SaveVaultAt(RecoverPath, APlainJson, AETag, ASyncPwd, False, False,
ASyncPwd, AKey, ASalt, AIterations, False)
else if TFile.Exists(RecoverPath) then
TFile.Delete(RecoverPath);
except
on E: Exception do
FLastStoreError := 'recovery copy not written: ' + E.Message;
end;
end;
function LoadVaultAt(const APath: string; out APlainJson, AETag, ASyncPwd: string;
out AKey, ASalt: TBytes; out AIterations: Integer; out AKey, ASalt: TBytes; out AIterations: Integer;
const APin: string = ''): Boolean; const APin: string): Boolean;
{$IF DEFINED(ANDROID)} {$IF DEFINED(ANDROID)}
var var
LRaw, LIv, LCt, LPlain, LWrapped, LAesRaw, LInner, LSalt, LPinKey: TBytes; LRaw, LIv, LCt, LPlain, LWrapped, LAesRaw, LInner, LSalt, LPinKey: TBytes;
@@ -1114,10 +1162,10 @@ begin
ASalt := nil; ASalt := nil;
AIterations := 0; AIterations := 0;
FLastStoreError := ''; FLastStoreError := '';
if not TFile.Exists(VaultPath) then Exit; if not TFile.Exists(APath) then Exit;
try try
LRaw := TFile.ReadAllBytes(VaultPath); LRaw := TFile.ReadAllBytes(APath);
if Length(LRaw) < 1 then Exit; if Length(LRaw) < 1 then Exit;
if LRaw[0] = VER_PIN then if LRaw[0] = VER_PIN then
@@ -1268,4 +1316,21 @@ begin
end; end;
{$ENDIF} {$ENDIF}
function LoadVault(out APlainJson, AETag, ASyncPwd: string;
out AKey, ASalt: TBytes; out AIterations: Integer;
const APin: string = ''): Boolean;
begin
Result := LoadVaultAt(VaultPath, APlainJson, AETag, ASyncPwd, AKey, ASalt,
AIterations, APin);
end;
function LoadRecoveryVault(out APlainJson, AETag, ASyncPwd: string;
out AKey, ASalt: TBytes; out AIterations: Integer;
const APwd: string): Boolean;
begin
Result := (APwd <> '') and
LoadVaultAt(RecoverPath, APlainJson, AETag, ASyncPwd, AKey, ASalt,
AIterations, APwd);
end;
end. end.
+129 -2
View File
@@ -61,6 +61,7 @@ type
FBaseUrl: string; FBaseUrl: string;
FToken: string; FToken: string;
FTimeoutMs: Integer; FTimeoutMs: Integer;
FPrivacyChecked: Boolean;
public public
constructor Create(const ABaseUrl, AToken: string); constructor Create(const ABaseUrl, AToken: string);
@@ -73,6 +74,18 @@ type
/// n'y ressemble pas est de toute facon inutilisable. /// n'y ressemble pas est de toute facon inutilisable.
function IsGitea: Boolean; function IsGitea: Boolean;
/// UN DEPOT PUBLIC EST REFUSE (Gitea comme GitHub) : chaque synchro est un
/// commit, et l'historique garde tous les instantanes, attaquables hors
/// ligne par quiconque peut les lire. Message a afficher, ou '' si le depot
/// est prive ou si on n'a pas pu le savoir. Verifie une fois par instance.
function PublicRepoWarning: string;
/// POURQUOI UN 404 OU UN 401, en clair pour l'utilisateur. Gitea repond 404
/// aussi bien pour un fichier absent que pour un depot ou un proprietaire
/// inexistant : deux requetes de plus tranchent - le depot, puis
/// l'utilisateur. Vide si rien de plus precis n'a pu etre etabli.
function Diagnose(AHttpCode: Integer): string;
/// Publie un conteneur. ASha est celui du fichier qu'on a lu : Gitea s'en /// Publie un conteneur. ASha est celui du fichier qu'on a lu : Gitea s'en
/// sert pour refuser (409) une ecriture si quelqu'un d'autre a publie /// sert pour refuser (409) une ecriture si quelqu'un d'autre a publie
/// entre-temps. Vide = creation d'un fichier qui n'existait pas. /// entre-temps. Vide = creation d'un fichier qui n'existait pas.
@@ -96,7 +109,107 @@ uses
function TSyncClient.IsGitea: Boolean; function TSyncClient.IsGitea: Boolean;
begin begin
Result := FBaseUrl.ToLower.Contains('/api/v1/repos/'); // GitHub parle la meme API des contenus : meme chemin pour les deux.
Result := FBaseUrl.ToLower.Contains('/api/v1/repos/') or
FBaseUrl.ToLower.Contains('api.github.com/repos/');
end;
/// URL de l'API du depot (sans /contents/...), identique pour Gitea
/// (https://hote/api/v1/repos/O/R) et GitHub (https://api.github.com/repos/O/R).
function RepoApiUrl(const AContentsUrl: string): string;
var
LP: Integer;
begin
LP := Pos('/contents/', AContentsUrl);
if LP > 0 then Result := Copy(AContentsUrl, 1, LP - 1) else Result := '';
end;
function TSyncClient.PublicRepoWarning: string;
var
LHttp: THTTPClient;
LResp: IHTTPResponse;
LDoc: TJSONObject;
LPriv: Boolean;
begin
Result := '';
if FPrivacyChecked or not IsGitea or (RepoApiUrl(FBaseUrl) = '') then Exit;
FPrivacyChecked := True;
LHttp := THTTPClient.Create;
try
LHttp.ConnectionTimeout := FTimeoutMs;
LHttp.ResponseTimeout := FTimeoutMs;
LHttp.HandleRedirects := False;
LHttp.UserAgent := 'PMServer';
LHttp.CustomHeaders['Authorization'] := 'token ' + FToken;
try
LResp := LHttp.Get(RepoApiUrl(FBaseUrl));
except
Exit; // doute reseau : pas de verdict, la vraie requete le dira
end;
if LResp.StatusCode <> 200 then Exit;
LDoc := TJSONObject.ParseJSONValue(LResp.ContentAsString(TEncoding.UTF8)) as TJSONObject;
if LDoc = nil then Exit;
try
if LDoc.TryGetValue<Boolean>('private', LPriv) and not LPriv then
Result := 'This repository is PUBLIC - make it private before syncing: anyone could download your encrypted vault and all its history.';
finally
LDoc.Free;
end;
finally
LHttp.Free;
end;
end;
function TSyncClient.Diagnose(AHttpCode: Integer): string;
var
LHttp: THTTPClient;
LApi, LOwner, LRepo: string;
LParts: TArray<string>;
LP: Integer;
function CodeOf(const AUrl: string): Integer;
begin
try
Result := LHttp.Get(AUrl).StatusCode;
except
Result := 0;
end;
end;
begin
Result := '';
if AHttpCode = 401 then
Exit('Token refused - expired, revoked or mistyped');
if (AHttpCode <> 404) or not IsGitea then Exit;
// https://hote/api/v1/repos/O/R/contents/F ou https://api.github.com/repos/O/R/...
// Tout ce qui precede "repos/" est la racine de l'API, pour les deux.
LP := Pos('/repos/', LowerCase(FBaseUrl));
if LP = 0 then Exit;
LApi := Copy(FBaseUrl, 1, LP);
LParts := Copy(FBaseUrl, LP + Length('/repos/'), MaxInt).Split(['/']);
if Length(LParts) < 2 then Exit;
LOwner := LParts[0];
LRepo := LParts[1];
LHttp := THTTPClient.Create;
try
LHttp.ConnectionTimeout := FTimeoutMs;
LHttp.ResponseTimeout := FTimeoutMs;
LHttp.HandleRedirects := False;
LHttp.UserAgent := 'PMServer';
LHttp.CustomHeaders['Authorization'] := 'token ' + FToken;
case CodeOf(LApi + 'repos/' + LOwner + '/' + LRepo) of
200: Result := 'No vault in this repository yet - sync from the PC first';
401: Result := 'Token refused - expired, revoked or mistyped';
404:
if CodeOf(LApi + 'users/' + LOwner) = 404 then
Result := 'User "' + LOwner + '" does not exist'
else
Result := 'Repository "' + LOwner + '/' + LRepo +
'" not found, or this token cannot see it';
end;
finally
LHttp.Free;
end;
end; end;
/// Le sha du fichier ecrit, tire de la reponse au PUT : Gitea rend /// Le sha du fichier ecrit, tire de la reponse au PUT : Gitea rend
@@ -182,7 +295,7 @@ begin
if not IsGitea then if not IsGitea then
begin begin
Result.Status := ssHttpError; Result.Status := ssHttpError;
Result.Error := 'Ecriture disponible seulement vers un depot Gitea'; Result.Error := 'Ecriture disponible seulement vers un depot Gitea ou GitHub';
Exit; Exit;
end; end;
if (FBaseUrl = '') or (FToken = '') then if (FBaseUrl = '') or (FToken = '') then
@@ -190,6 +303,12 @@ begin
Result.Error := 'URL ou jeton non configure'; Result.Error := 'URL ou jeton non configure';
Exit; Exit;
end; end;
Result.Error := PublicRepoWarning;
if Result.Error <> '' then
begin
Result.Status := ssRefused; // HttpCode 0 : refus local, pas du serveur
Exit;
end;
LEnv := TJSONObject.Create; LEnv := TJSONObject.Create;
LB64 := TBase64Encoding.Create(0); // pas de coupure : voir PMA.Crypto LB64 := TBase64Encoding.Create(0); // pas de coupure : voir PMA.Crypto
@@ -211,6 +330,7 @@ begin
LHttp.ConnectionTimeout := FTimeoutMs; LHttp.ConnectionTimeout := FTimeoutMs;
LHttp.ResponseTimeout := FTimeoutMs; LHttp.ResponseTimeout := FTimeoutMs;
LHttp.HandleRedirects := False; LHttp.HandleRedirects := False;
LHttp.UserAgent := 'PMServer'; // GitHub refuse toute requete sans
LHttp.CustomHeaders['Authorization'] := 'token ' + FToken; LHttp.CustomHeaders['Authorization'] := 'token ' + FToken;
LHttp.CustomHeaders['Content-Type'] := 'application/json'; LHttp.CustomHeaders['Content-Type'] := 'application/json';
try try
@@ -291,11 +411,18 @@ begin
Result.Error := 'URL ou jeton non configure'; Result.Error := 'URL ou jeton non configure';
Exit; Exit;
end; end;
Result.Error := PublicRepoWarning;
if Result.Error <> '' then
begin
Result.Status := ssRefused; // HttpCode 0 : refus local, pas du serveur
Exit;
end;
LHttp := THTTPClient.Create; LHttp := THTTPClient.Create;
try try
LHttp.ConnectionTimeout := FTimeoutMs; LHttp.ConnectionTimeout := FTimeoutMs;
LHttp.ResponseTimeout := FTimeoutMs; LHttp.ResponseTimeout := FTimeoutMs;
LHttp.UserAgent := 'PMServer'; // GitHub refuse toute requete sans
// Pas de redirection suivie : une redirection vers un autre hote nous // Pas de redirection suivie : une redirection vers un autre hote nous
// ferait envoyer le jeton ailleurs. // ferait envoyer le jeton ailleurs.
LHttp.HandleRedirects := False; LHttp.HandleRedirects := False;
+2
View File
@@ -131,6 +131,8 @@ begin
LObj.AddPair('initial', Initial(E.Display)); LObj.AddPair('initial', Initial(E.Display));
LObj.AddPair('hasUser', TJSONBool.Create(E.Username <> '')); LObj.AddPair('hasUser', TJSONBool.Create(E.Username <> ''));
LObj.AddPair('isNote', TJSONBool.Create(E.IsNote)); LObj.AddPair('isNote', TJSONBool.Create(E.IsNote));
// Un booleen, jamais le secret : le code se calcule chez Delphi a la copie.
LObj.AddPair('hasTotp', TJSONBool.Create(E.Totp <> ''));
LEntries.AddElement(LObj); LEntries.AddElement(LObj);
end; end;
+170 -1
View File
@@ -176,7 +176,8 @@ Node ouvre le fichier et pas le client, le défaut est dans le client.
| `PMA.Biometric.pas` | authentification via `FMX.BiometricAuth` | | `PMA.Biometric.pas` | authentification via `FMX.BiometricAuth` |
| `PMA.Vault.pas` | l'instantané en mémoire : lecture et recherche | | `PMA.Vault.pas` | l'instantané en mémoire : lecture et recherche |
| `PMA.Totp.pas` | codes TOTP (RFC 6238), base32 ou `otpauth://` | | `PMA.Totp.pas` | codes TOTP (RFC 6238), base32 ou `otpauth://` |
| `PMA.ScreenGuard.pas` | `FLAG_SECURE` (Release seulement) | | `PMA.ScreenGuard.pas` | `FLAG_SECURE` (Release seulement) — bloque aussi `adb exec-out screencap` |
| `ThirdParty/ZXing/` | ZXing.Delphi (Apache 2.0), décodage du QR des réglages |
| `selftest.dpr` | vérification console : conteneur + TOTP | | `selftest.dpr` | vérification console : conteneur + TOTP |
| `PMA.TestVector.pas` | le vecteur embarqué, plus référencé par l'interface | | `PMA.TestVector.pas` | le vecteur embarqué, plus référencé par l'interface |
| `make-testvector.js` | régénère le vecteur avec WebCrypto | | `make-testvector.js` | régénère le vecteur avec WebCrypto |
@@ -184,6 +185,158 @@ Node ouvre le fichier et pas le client, le défaut est dans le client.
L'interface est `mainApk.pas`, à la racine du dépôt. L'interface est `mainApk.pas`, à la racine du dépôt.
## Trois façons d'ouvrir le coffre — 2026-09-17
`Settings → Unlock with` : le **verrouillage d'écran** (schéma, code,
empreinte, visage), un **code d'application**, ou le **mot de passe** qui ouvre
le coffre. Le bouton en place porte une coche, et la note dit lequel est actif.
Le coffre lui-même n'est jamais touché : seul le scellement de `vault.bin`
change (`VER_WRAP` ↔ `VER_PIN`).
- Le nom du mot de passe **suit l'origine du coffre** : « sync password » pour
un coffre venu du dépôt, « vault password » pour un coffre créé sur le
téléphone. `TForm8.PwdName` et `PushUnlockMode` le décident, et le libellé se
repose à chaque `AdoptVault` — sinon un téléchargement laissait l'ancien.
- Revenir au verrouillage d'écran demande de **retaper le code courant** :
retirer une protection exige de la connaître.
- Sans verrouillage d'écran sur l'appareil, le bouton est grisé et **dit
pourquoi** au lieu de rester muet.
### La copie de secours, pour survivre au schéma retiré
Retirer ou réinitialiser le verrouillage d'écran fait **détruire par Android**
la clé qui scelle `vault.bin` : le coffre devenait illisible et il fallait le
retélécharger. `SaveVault` écrit donc, **tant que le cache est en `VER_WRAP`**,
une seconde copie `vault-recover.bin` scellée sous le mot de passe (format
`VER_PIN` : clé d'appareil sans contrainte + PBKDF2), qu'Android n'invalide
jamais.
- Tout autre scellement l'efface : en mode code ou mot de passe, elle
n'apporterait rien.
- À l'ouverture, `OpenVault` bascule dessus quand il n'y a plus de
verrouillage utilisable, et `OpenLocalNow` quand le système vient de déclarer
la clé morte (`LastStoreKeyInvalidated`). L'accueil demande alors le mot de
passe au lieu d'annoncer un coffre illisible.
- **Rescellé immédiatement** après cette ouverture : sous le nouveau
verrouillage s'il existe (clé neuve, l'ancienne est morte), sinon sous le mot
de passe. Le coffre ne reste jamais sans protection.
- Un coffre **venu seulement de la synchro** avant cette version n'a pas de
copie de secours : lui, il se retélécharge.
## Scanner le QR des réglages — 2026-09-17
Le poste affiche un QR (`Settings → Sync → QR for phone`) qui porte
`pmserver://sync?u=&t=` — URL du dépôt et jeton, **jamais** le mot de passe de
synchro. Deux chemins le reçoivent :
1. **`Settings → Scan the QR shown on the PC`** : aperçu caméra plein écran,
décodage par **`ThirdParty/ZXing`** (ZXing.Delphi, Apache 2.0).
2. **Le lien lui-même**, si un scanner extérieur l'ouvre : `intent-filter`
`VIEW` sur le schéma `pmserver` dans le manifeste, intent de départ lu au
`FormCreate` et suivants par `TMessageReceivedNotification`.
Dans les deux cas **rien n'est enregistré** : les champs se remplissent, c'est
`Save` qui valide. Le lien peut venir de n'importe où, et l'URL est sous les
yeux de l'utilisateur au moment où il valide.
Quatre défauts rencontrés, tous invisibles à la compilation :
| Symptôme | Cause |
|---|---|
| L'appareil photo propose « Ouvrir avec » et des navigateurs | il envoie tout **texte** à une recherche web ; d'où le schéma `pmserver://`, que seule l'app ouvre |
| Caméra noire au **premier** scan après l'autorisation | la fenêtre d'autorisation fait passer par `BecameActive`, qui remettait la vue web **par-dessus** l'aperçu ; elle ne le fait plus pendant un scan |
| Écran noir, aucune image | la caméra est tenue par une autre application (l'appareil photo, même en arrière-plan). Un guet de 3 s sans image le **dit** maintenant |
| QR lu mais ignoré | le texte décodé arrive avec un **caractère invisible** en tête (104 lus pour 103 émis) : on cherche le lien dans la chaîne au lieu de comparer le début |
Le décodage est lent et n'aboutit que sur une image de temps en temps — c'est un
portage Delphi, pas le scanner natif de Google. Une image sur quatre part au
décodage, jamais deux à la fois, et l'indice **`TRY_HARDER`** est indispensable
pour un QR photographié sur un écran.
## Créer un coffre ici : essais seulement (`AllowCreateLocal`)
Un coffre né sur le téléphone n'existe nulle part ailleurs — le poste ne le
connaît pas, et personne ne peut le rendre à qui perd son mot de passe. Le
define **`AllowCreateLocal`**, posé par `{$IFDEF DEBUG}` et jamais en release,
garde ce chemin pour les essais.
En release l'accueil n'offre que **Download vault** (`PM.setAuthMode("download")`),
et `RegisterLocal` refuse aussi : l'interdit ne tient pas qu'à l'écran. Dépôt
vide (404) ou conteneur illisible, **rien n'est créé** — un coffre neuf
masquerait un réglage à corriger.
## Erreurs du dépôt, générateur, Save — 2026-09-18
- **Une erreur de réglage s'affiche là où on la corrige** : `ShowSettingsError`
ouvre les réglages avec le message en rouge au-dessus des champs du dépôt.
Download vault sans URL ni jeton, jeton refusé, dépôt ou utilisateur
inexistant, mauvais mot de passe de synchro, dépôt public.
- **Gitea répond 404 pour tout** (fichier absent, dépôt ou propriétaire
inexistant, dépôt privé invisible au jeton). `TSyncClient.Diagnose` tranche
par deux requêtes de plus — le dépôt, puis l'utilisateur —, seulement quand
quelqu'un attend la réponse. Même logique pour GitHub (racine de l'API = tout
ce qui précède `repos/`).
- **Générateur de mot de passe** : dé à côté du champ, à la création et à la
modification. `crypto.getRandomValues` avec rejet (un modulo favoriserait les
premiers caractères), 20 caractères, laissé visible une fois tiré.
- **Save ne s'allume que sur un vrai changement**, comparé aux valeurs
enregistrées : taper puis effacer le regrise. Après Save : « ✓ Saved »,
inactif, nouvelle référence.
### Le mot de passe de synchro : celui qu'on tape l'emporte, mais se vérifie
Le cache porte le mot de passe de synchro. Rouvrir le coffre le **reposait**
dans les réglages, par-dessus celui que l'utilisateur venait d'enregistrer : le
changement disparaissait sans un mot (`FPwdUserSet` l'empêche désormais).
Et un mot de passe changé **n'était jamais vérifié** : le `sha` inchangé faisait
répondre « rien n'a changé » sans rien déchiffrer. Tant que `FPwdUserSet`, le
dépôt est donc **retéléchargé en entier** (`Fetch('')`), le déchiffrement
tranche, puis la synchro reprend si des modifications attendaient. Les
publications, elles, n'étaient pas en danger : `CommitChange` et
`PublishPending` chiffrent avec `FKey`, la clé du dernier mot de passe qui a
réellement ouvert le dépôt.
## Copier plus vite — 2026-09-18
**Settings → Copy and search**, deux cases, sans **Save** (elles s'appliquent au
toucher, fichier `ui-prefs.txt` dans le dossier privé, rien de secret) :
- **Recherche prête** (cochée par défaut) : à l'ouverture du coffre et au retour
dans Vault, le curseur est dans la recherche, le texte précédent sélectionné,
et le clavier déplié (`PM.focusSearch` puis `kbd` → `ShowSoftKeyboard` : un
`focus()` JavaScript seul pose le curseur **sans** ouvrir le clavier). Pas
après un enregistrement ni un rafraîchissement de fond : le clavier surgirait
au milieu d'autre chose.
- **Cacher Vault après une copie** (décochée par défaut) : `moveTaskToBack`.
**Android ne laisse pas choisir l'app qui passe devant** — selon la façon dont
Vault a été ouvert (lanceur, apps récentes), c'est l'écran d'accueil qui
revient, pas l'app d'avant. Le geste fiable est celui d'Android : glisser le
long de la barre du bas, ou double appui sur le bouton des apps récentes.
**2 minutes de grâce après une copie** (`COPY_GRACE_SECONDS`), 30 s sinon : on
part coller l'identifiant et on revient chercher le mot de passe, et le coffre
se reverrouillait au milieu du geste.
**Code 2FA sur chaque ligne** : icône d'horloge sur les entrées qui ont un
secret (`hasTotp`, un booléen — jamais le secret dans la page). Le code est
calculé à l'instant de la copie ; le message dit combien de secondes il lui
reste.
## Saisie : ce qui a résisté
- **`user-select: none` du `body`** était hérité par les champs : le curseur ne
suivait pas le doigt et le texte ne défilait jamais, donc la fin d'une URL
restait hors d'atteinte. Les champs ont leur exception, mais **ça n'a pas
suffi** : l'URL est désormais une `textarea` qui passe à la ligne et prend la
hauteur de son texte.
- La **croix** d'effacement couvrait toute la marge droite : toucher la fin du
texte effaçait le champ. Elle est plus étroite que la marge.
- **`Save` est un geste** : fermer les réglages n'enregistre plus rien. Une URL
effacée par erreur revient en revenant en arrière.
- L'URL s'affiche en **forme courte** (`https://hôte/Owner/Repo`) et
`normalizeRepoUrl` la rallonge en URL d'API à l'enregistrement.
## Fabriquer l'APK en ligne de commande ## Fabriquer l'APK en ligne de commande
L'EDI y arrive seul ; MSBuild non, et l'erreur ne dit pas pourquoi. L'EDI y arrive seul ; MSBuild non, et l'erreur ne dit pas pourquoi.
@@ -229,6 +382,22 @@ signature* sur le dossier déjà prêt, sans le vider :
android-client\repack-apk.ps1 android-client\repack-apk.ps1
``` ```
> **La sortie Android vit sur `E:`.** `Z:` est arrivé à 40 Ko libres le
> 2026-09-17 et `aapt` échouait sans dire pourquoi. `Z:\password-manager\Android64`
> est désormais une **jonction** vers `E:\password manager\Android64` : les
> scripts et le `.dproj` n'ont pas changé, et rien de machine-dépendant n'est
> entré dans le dépôt.
> **La release n'est plus `debuggable`.** Delphi écrit
> `android:debuggable="true"` dans le manifeste **même en Release**, et l'APK
> livré le portait. Sur un téléphone où le débogage USB est actif, `adb run-as`
> ouvrait alors le dossier privé de l'application — donc `vault.bin` et les
> réglages — sans accès root. `build-apk.ps1` force l'attribut à `false` dans
> le manifeste mis en scène, **et seulement pour une release**. Vérification :
> `adb shell dumpsys package com.embarcadero.pmserverApk` ne doit plus lister
> `DEBUGGABLE` dans `pkgFlags`. Conséquence assumée : plus de `run-as` ni de
> capture d'écran sur une release, c'est-à-dire plus d'inspection à distance.
> **Place disque.** Le `.so` de debug pèse **91 Mo** (symboles), et le volume > **Place disque.** Le `.so` de debug pèse **91 Mo** (symboles), et le volume
> `Z:` n'en fait que 2 Go. Le dépouiller avec le `strip` du NDK le ramène à > `Z:` n'en fait que 2 Go. Le dépouiller avec le `strip` du NDK le ramène à
> 54 Mo, et l'APK final à 16 Mo — mais `strip` écrit sa copie temporaire **à > 54 Mo, et l'APK final à 16 Mo — mais `strip` écrit sa copie temporaire **à
@@ -0,0 +1,696 @@
{
* Copyright 2008 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Original Authors: Sean Owen
* Delphi Implementation by E. Spelt and K. Gossens
}
unit ZXing.OneD.Code128Reader;
interface
uses
System.SysUtils,
System.Generics.Collections,
System.Math,
ZXing.Helpers,
ZXing.OneD.OneDReader,
ZXing.Common.BitArray,
ZXing.ReadResult,
ZXing.DecodeHintType,
ZXing.ResultPoint,
ZXing.BarcodeFormat;
var
CODE_PATTERNS: TArray<TArray<Integer>>;
type
/// <summary>
/// <p>Decodes Code 128 barcodes.</p>
/// </summary>
TCode128Reader = class(TOneDReader)
private const
CODE_SHIFT = 98;
CODE_CODE_C = 99;
CODE_CODE_B = 100;
CODE_CODE_A = 101;
CODE_FNC_1 = 102;
CODE_FNC_2 = 97;
CODE_FNC_3 = 96;
CODE_FNC_4_A = 101;
CODE_FNC_4_B = 100;
CODE_START_A = 103;
CODE_START_B = 104;
CODE_START_C = 105;
CODE_STOP = 106;
class var MAX_AVG_VARIANCE: Integer;
class var MAX_INDIVIDUAL_VARIANCE: Integer;
class function FindStartPattern(row: IBitArray): TArray<Integer>;
class function DecodeCode(row: IBitArray; counters: TArray<Integer>;
rowOffset: Integer; var code: Integer): Boolean;
class procedure DoInitialize();
class procedure DoFinalize();
public
function decodeRow(const rowNumber: Integer; const row: IBitArray;
const hints: TDictionary<TDecodeHintType, TObject>): TReadResult;
override;
end;
implementation
class procedure TCode128Reader.DoFinalize;
begin
CODE_PATTERNS := nil;
end;
class procedure TCode128Reader.DoInitialize;
begin
CODE_PATTERNS := [[2, 1, 2, 2, 2, 2], // 0
[2, 2, 2, 1, 2, 2], [2, 2, 2, 2, 2, 1], [1, 2, 1, 2, 2, 3],
[1, 2, 1, 3, 2, 2], [1, 3, 1, 2, 2, 2], // 5
[1, 2, 2, 2, 1, 3], [1, 2, 2, 3, 1, 2], [1, 3, 2, 2, 1, 2],
[2, 2, 1, 2, 1, 3], [2, 2, 1, 3, 1, 2], // 10
[2, 3, 1, 2, 1, 2], [1, 1, 2, 2, 3, 2], [1, 2, 2, 1, 3, 2],
[1, 2, 2, 2, 3, 1], [1, 1, 3, 2, 2, 2], // 15
[1, 2, 3, 1, 2, 2], [1, 2, 3, 2, 2, 1], [2, 2, 3, 2, 1, 1],
[2, 2, 1, 1, 3, 2], [2, 2, 1, 2, 3, 1], // 20
[2, 1, 3, 2, 1, 2], [2, 2, 3, 1, 1, 2], [3, 1, 2, 1, 3, 1],
[3, 1, 1, 2, 2, 2], [3, 2, 1, 1, 2, 2], // 25
[3, 2, 1, 2, 2, 1], [3, 1, 2, 2, 1, 2], [3, 2, 2, 1, 1, 2],
[3, 2, 2, 2, 1, 1], [2, 1, 2, 1, 2, 3], // 30
[2, 1, 2, 3, 2, 1], [2, 3, 2, 1, 2, 1], [1, 1, 1, 3, 2, 3],
[1, 3, 1, 1, 2, 3], [1, 3, 1, 3, 2, 1], // 35
[1, 1, 2, 3, 1, 3], [1, 3, 2, 1, 1, 3], [1, 3, 2, 3, 1, 1],
[2, 1, 1, 3, 1, 3], [2, 3, 1, 1, 1, 3], // 40
[2, 3, 1, 3, 1, 1], [1, 1, 2, 1, 3, 3], [1, 1, 2, 3, 3, 1],
[1, 3, 2, 1, 3, 1], [1, 1, 3, 1, 2, 3], // 45
[1, 1, 3, 3, 2, 1], [1, 3, 3, 1, 2, 1], [3, 1, 3, 1, 2, 1],
[2, 1, 1, 3, 3, 1], [2, 3, 1, 1, 3, 1], // 50
[2, 1, 3, 1, 1, 3], [2, 1, 3, 3, 1, 1], [2, 1, 3, 1, 3, 1],
[3, 1, 1, 1, 2, 3], [3, 1, 1, 3, 2, 1], // 55
[3, 3, 1, 1, 2, 1], [3, 1, 2, 1, 1, 3], [3, 1, 2, 3, 1, 1],
[3, 3, 2, 1, 1, 1], [3, 1, 4, 1, 1, 1], // 60
[2, 2, 1, 4, 1, 1], [4, 3, 1, 1, 1, 1], [1, 1, 1, 2, 2, 4],
[1, 1, 1, 4, 2, 2], [1, 2, 1, 1, 2, 4], // 65
[1, 2, 1, 4, 2, 1], [1, 4, 1, 1, 2, 2], [1, 4, 1, 2, 2, 1],
[1, 1, 2, 2, 1, 4], [1, 1, 2, 4, 1, 2], // 70
[1, 2, 2, 1, 1, 4], [1, 2, 2, 4, 1, 1], [1, 4, 2, 1, 1, 2],
[1, 4, 2, 2, 1, 1], [2, 4, 1, 2, 1, 1], // 75
[2, 2, 1, 1, 1, 4], [4, 1, 3, 1, 1, 1], [2, 4, 1, 1, 1, 2],
[1, 3, 4, 1, 1, 1], [1, 1, 1, 2, 4, 2], // 80
[1, 2, 1, 1, 4, 2], [1, 2, 1, 2, 4, 1], [1, 1, 4, 2, 1, 2],
[1, 2, 4, 1, 1, 2], [1, 2, 4, 2, 1, 1], // 85
[4, 1, 1, 2, 1, 2], [4, 2, 1, 1, 1, 2], [4, 2, 1, 2, 1, 1],
[2, 1, 2, 1, 4, 1], [2, 1, 4, 1, 2, 1], // 90
[4, 1, 2, 1, 2, 1], [1, 1, 1, 1, 4, 3], [1, 1, 1, 3, 4, 1],
[1, 3, 1, 1, 4, 1], [1, 1, 4, 1, 1, 3], // 95
[1, 1, 4, 3, 1, 1], [4, 1, 1, 1, 1, 3], [4, 1, 1, 3, 1, 1],
[1, 1, 3, 1, 4, 1], [1, 1, 4, 1, 3, 1], // 100
[3, 1, 1, 1, 4, 1], [4, 1, 1, 1, 3, 1], [2, 1, 1, 4, 1, 2],
[2, 1, 1, 2, 1, 4], [2, 1, 1, 2, 3, 2], // 105
[2, 3, 3, 1, 1, 1, 2]];
MAX_AVG_VARIANCE := Floor(PATTERN_MATCH_RESULT_SCALE_FACTOR * 0.25);
MAX_INDIVIDUAL_VARIANCE := Floor(PATTERN_MATCH_RESULT_SCALE_FACTOR * 0.7);
end;
class function TCode128Reader.FindStartPattern(row: IBitArray): TArray<Integer>;
var
i, bestMatch, startCode, bestVariance, width, rowOffset, patternStart,
patternLength, variance, counterPosition: Integer;
counters: TArray<Integer>;
isWhite: Boolean;
begin
width := row.Size;
rowOffset := row.getNextSet(0);
counterPosition := 0;
counters := TArray<Integer>.Create();
SetLength(counters, 6);
patternStart := rowOffset;
isWhite := false;
patternLength := Length(counters);
for i := rowOffset to width - 1 do
begin
if row[i] xor isWhite then
begin
inc(counters[counterPosition])
end
else
begin
if counterPosition = patternLength - 1 then
begin
bestVariance := MAX_AVG_VARIANCE;
bestMatch := -1;
startCode := CODE_START_A;
while startCode <= CODE_START_C do
begin
variance := patternMatchVariance(counters, CODE_PATTERNS[startCode],
MAX_INDIVIDUAL_VARIANCE);
if variance < bestVariance then
begin
bestVariance := variance;
bestMatch := startCode
end;
inc(startCode);
end;
if bestMatch >= 0 then
begin
// Look for whitespace before start pattern, >= 50% of width of start pattern
if row.isRange(Max(0, patternStart - (i - patternStart) div 2),
patternStart, false) then
begin
result := [patternStart, i, bestMatch];
exit;
end
end;
patternStart := patternStart + counters[0] + counters[1];
// Array.Copy(counters, 2, counters, 0, patternLength - 2);
// source, source index, dest, dest index, lengte
counters := TArray.CopyInSameArray(counters, 2, patternLength - 2);
counters[patternLength - 2] := 0;
counters[patternLength - 1] := 0;
dec(counterPosition);
end
else
begin
inc(counterPosition);
end;
counters[counterPosition] := 1;
isWhite := not isWhite
end;
end;
result := nil;
end;
class function TCode128Reader.DecodeCode(row: IBitArray;
counters: TArray<Integer>; rowOffset: Integer; var code: Integer): Boolean;
var
bestVariance, l, d, variance: Integer;
pattern: TArray<Integer>;
begin
code := -1;
if not recordPattern(row, rowOffset, counters) then
begin
result := false;
exit;
end;
bestVariance := MAX_AVG_VARIANCE;
// worst variance we'll accept
l := Length(CODE_PATTERNS) - 1;
for d := 0 to l do
begin
pattern := CODE_PATTERNS[d];
variance := patternMatchVariance(counters, pattern,
MAX_INDIVIDUAL_VARIANCE);
if variance < bestVariance then
begin
bestVariance := variance;
code := d
end;
end;
// TODO We're overlooking the fact that the STOP pattern has 7 values, not 6.
result := code >= 0;
end;
function TCode128Reader.decodeRow(const rowNumber: Integer;
const row: IBitArray; const hints: TDictionary<TDecodeHintType, TObject>)
: TReadResult;
var
shiftUpperMode, upperMode, lastCharacterWasPrintable, convertFNC1, done,
unshift, isNextShifted: Boolean;
counters, startPatternInfo: TArray<Integer>;
lastPatternSize, multiplier, checksumTotal, code, lastCode, nextStart,
lastStart, startCode, codeSet, l, rawCodesSize: Integer;
rawCodes: TList<Byte>;
rawBytes: TArray<Byte>;
aResult: String;
counter, resultLength, i: Integer;
left, right: Single;
resultPointCallback: TResultPointCallback;
obj: TObject;
resultPoints: TArray<IResultPoint>;
resultPointLeft, resultPointRight: IResultPoint;
begin
convertFNC1 := (hints <> nil) and
(hints.ContainsKey(ZXing.DecodeHintType.ASSUME_GS1));
startPatternInfo := FindStartPattern(row);
if (startPatternInfo = nil) then
begin
result := nil;
exit;
end;
startCode := startPatternInfo[2];
rawCodes := TList<Byte>.Create();
try
rawCodes.Add(Byte(startCode));
case startCode of
CODE_START_A:
begin
codeSet := CODE_CODE_A;
end;
CODE_START_B:
begin
codeSet := CODE_CODE_B;
end;
CODE_START_C:
begin
codeSet := CODE_CODE_C;
end
else
result := nil;
exit;
end;
done := false;
isNextShifted := false;
lastStart := startPatternInfo[0];
nextStart := startPatternInfo[1];
SetLength(counters, 6);
lastCode := 0;
code := 0;
checksumTotal := startCode;
multiplier := 0;
lastCharacterWasPrintable := true;
upperMode := false;
shiftUpperMode := false;
while not done do
begin
unshift := isNextShifted;
isNextShifted := false;
// Save off last code
lastCode := code;
// Decode another code from image
if not DecodeCode(row, counters, nextStart, code) then
begin
result := nil;
exit;
end;
rawCodes.Add(Byte(code));
// Remember whether the last code was printable or not (excluding CODE_STOP)
if code <> CODE_STOP then
begin
lastCharacterWasPrintable := true
end;
// Add to checksum computation (if not CODE_STOP of course)
if code <> CODE_STOP then
begin
inc(multiplier);
checksumTotal := checksumTotal + (multiplier * code);
end;
// Advance to where the next code will to start
lastStart := nextStart;
l := Length(counters) - 1;
for counter := 0 to l do
begin
nextStart := nextStart + counters[counter];
end;
// Take care of illegal start codes
case code of
CODE_START_A, CODE_START_B, CODE_START_C:
begin
result := nil;
exit;
end;
end;
case codeSet of
CODE_CODE_A:
begin
if code < 64 then
begin
if shiftUpperMode = upperMode then
begin
aResult := aResult + Char(32 + code);
end
else
begin
aResult := aResult + Char(32 + 128)
end;
shiftUpperMode := false
end
else if code < 96 then
begin
if shiftUpperMode = upperMode then
begin
aResult := aResult + Char(code - 64)
end
else
begin
aResult := aResult + Char(code + 64)
end;
shiftUpperMode := false
end
else
begin
// Don't let CODE_STOP, which always appears, affect whether whether we think the last
// code was printable or not.
if code <> CODE_STOP then
begin
lastCharacterWasPrintable := false
end;
case code of
CODE_FNC_1:
begin
if convertFNC1 then
begin
if Length(aResult) = 0 then
begin
// GS1 specification 5.4.3.7. and 5.4.6.4. If the first char after the start code
// is FNC1 then this is GS1-128. We add the symbology identifier.
aResult := aResult + ']C1'
end
else
begin
// GS1 specification 5.4.7.5. Every subsequent FNC1 is returned as ASCII 29 (GS)
aResult := aResult + Char(29)
end
end;
end;
CODE_FNC_2, CODE_FNC_3:
begin
// do nothing?
end;
CODE_FNC_4_A:
begin
if (not upperMode) and (shiftUpperMode) then
begin
upperMode := true;
shiftUpperMode := false
end
else if (upperMode) and (shiftUpperMode) then
begin
upperMode := false;
shiftUpperMode := false
end
else
begin
shiftUpperMode := true
end;
end;
CODE_SHIFT:
begin
isNextShifted := true;
codeSet := CODE_CODE_B;
end;
CODE_CODE_B:
begin
codeSet := CODE_CODE_B;
end;
CODE_CODE_C:
begin
codeSet := CODE_CODE_C;
end;
CODE_STOP:
begin
done := true;
end;
end
end;
end;
CODE_CODE_B:
begin
if code < 96 then
begin
if shiftUpperMode = upperMode then
begin
aResult := aResult + Char(32 + code)
end
else
begin
aResult := aResult + Char(32 + code + 128)
end;
shiftUpperMode := false
end
else
begin
if code <> CODE_STOP then
begin
lastCharacterWasPrintable := false
end;
case code of
CODE_FNC_1:
begin
if convertFNC1 then
begin
if Length(aResult) = 0 then
begin
// GS1 specification 5.4.3.7. and 5.4.6.4. If the first char after the start code
// is FNC1 then this is GS1-128. We add the symbology identifier.
aResult := aResult + (']C1')
end
else
begin
// GS1 specification 5.4.7.5. Every subsequent FNC1 is returned as ASCII 29 (GS)
aResult := aResult + Char(29)
end
end;
end;
CODE_FNC_2, CODE_FNC_3:
begin
// do nothing?
end;
CODE_FNC_4_B:
begin
if (not upperMode) and (shiftUpperMode) then
begin
upperMode := true;
shiftUpperMode := false
end
else if (upperMode) and (shiftUpperMode) then
begin
upperMode := false;
shiftUpperMode := false
end
else
begin
shiftUpperMode := true
end;
end;
CODE_SHIFT:
begin
isNextShifted := true;
codeSet := CODE_CODE_A;
end;
CODE_CODE_A:
begin
codeSet := CODE_CODE_A;
end;
CODE_CODE_C:
begin
codeSet := CODE_CODE_C;
end;
CODE_STOP:
begin
done := true;
end;
end
end;
end;
CODE_CODE_C:
begin
if code < 100 then
begin
if code < 10 then
begin
aResult := aResult + ('0')
end;
aResult := aResult + IntToStr(code);
end
else
begin
if code <> CODE_STOP then
begin
lastCharacterWasPrintable := false
end;
case code of
CODE_FNC_1:
begin
if convertFNC1 then
begin
if Length(aResult) = 0 then
begin
// GS1 specification 5.4.3.7. and 5.4.6.4. If the first char after the start code
// is FNC1 then this is GS1-128. We add the symbology identifier.
aResult := aResult + (']C1')
end
else
begin
// GS1 specification 5.4.7.5. Every subsequent FNC1 is returned as ASCII 29 (GS)
aResult := aResult + Char(29)
end
end;
end;
CODE_CODE_A:
begin
codeSet := CODE_CODE_A;
end;
CODE_CODE_B:
begin
codeSet := CODE_CODE_B;
end;
CODE_STOP:
begin
done := true;
end;
end
end;
end;
end;
// Unshift back to another code set if we were shifted
if (unshift) then
begin
if (codeSet = CODE_CODE_A) then
codeSet := CODE_CODE_B
else
codeSet := CODE_CODE_A;
end;
end;
lastPatternSize := nextStart - lastStart;
// Check for ample whitespace following pattern, but, to do this we first need to remember that
// we fudged decoding CODE_STOP since it actually has 7 bars, not 6. There is a black bar left
// to read off. Would be slightly better to properly read. Here we just skip it:
nextStart := row.getNextUnset(nextStart);
if not row.isRange(nextStart, System.Math.Min(row.Size,
nextStart + (nextStart - lastStart) div 2), false) then
begin
result := nil;
exit;
end;
// Pull out from sum the value of the penultimate check code
checksumTotal := checksumTotal - (multiplier * lastCode);
// lastCode is the checksum then:
if checksumTotal mod 103 <> lastCode then
begin
result := nil;
exit;
end;
// Need to pull out the check digits from string
resultLength := Length(aResult);
if resultLength = 0 then
begin
// false positive
result := nil;
exit;
end;
// Only bother if the result had at least one character, and if the checksum digit happened to
// be a printable character. If it was just interpreted as a control code, nothing to remove.
if (resultLength > 0) and (lastCharacterWasPrintable) then
begin
if codeSet = CODE_CODE_C then
begin
aResult := aResult.Remove(resultLength - 2, 2);
end
else
begin
aResult := aResult.Remove(resultLength - 1, 1);
end
end;
left := (startPatternInfo[1] + startPatternInfo[0]) / 2;
right := lastStart + lastPatternSize / 2;
rawCodesSize := rawCodes.Count;
SetLength(rawBytes, rawCodesSize);
for i := 0 to rawCodesSize - 1 do
rawBytes[i] := rawCodes[i];
resultPointLeft := TResultPointHelpers.CreateResultPoint(left, rowNumber);
resultPointRight := TResultPointHelpers.CreateResultPoint(right, rowNumber);
resultPoints := [resultPointLeft, resultPointRight];
resultPointCallback := nil;
// had to add this initialization because the following if/else construct does not assign a value
// for all possible cases. Being resultPointCallback a local variable it is not initialized by default to null,
// so you could get unpredictable results
if ((hints = nil) or
(not hints.ContainsKey(TDecodeHintType.NEED_RESULT_POINT_CALLBACK))) then
resultPointCallback := nil
else
begin
obj := hints[TDecodeHintType.NEED_RESULT_POINT_CALLBACK];
if (obj is TResultPointEventObject) then
resultPointCallback := TResultPointEventObject(obj).Event;
end;
if Assigned(resultPointCallback) then
begin
resultPointCallback(resultPointLeft);
resultPointCallback(resultPointRight);
end;
finally
FreeAndNil(rawCodes);
end;
result := TReadResult.Create(aResult, rawBytes, resultPoints,
TBarcodeFormat.CODE_128);
end;
initialization
TCode128Reader.DoInitialize;
finalization
TCode128Reader.DoFinalize;
end.
@@ -0,0 +1,471 @@
unit ZXing.OneD.Code39Reader;
{
* Copyright 2008 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Original Authors: Sean Owen
* Implemented by Nano103 and E. Spelt for Delphi
}
interface
uses
System.SysUtils,
System.Generics.Collections,
Math,
ZXing.OneD.OneDReader,
ZXing.Common.BitArray,
ZXing.ReadResult,
ZXing.DecodeHintType,
ZXing.ResultPoint,
ZXing.BarcodeFormat,
ZXing.Common.Detector.MathUtils;
type
TCode39Reader = class sealed(TOneDReader)
private
class var ALPHABET: TArray<Char>;
class function decodeExtended(encoded: string): string; static;
function findAsteriskPattern(row: IBitArray): TArray<Integer>;
class function patternToChar(pattern: Integer; var c: Char)
: boolean; static;
class function toNarrowWidePattern(counters: TArray<Integer>)
: Integer; static;
const
ALPHABET_STRING: string = '0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-. *$/+%';
class var ASTERISK_ENCODING: Integer;
class var
CHARACTER_ENCODINGS: TArray<Integer>;
counters: TArray<Integer>;
decodeRowResult: TStringBuilder;
usingCheckDigit: boolean;
extendedMode: boolean;
public
function decodeRow(const rowNumber: Integer; const row: IBitArray;
const hints: TDictionary<TDecodeHintType, TObject>): TReadResult;
override;
constructor Create(AUsingCheckDigit, AExtendedMode: boolean);
destructor Destroy(); override;
end;
implementation
{ Code93Reader }
constructor TCode39Reader.Create(AUsingCheckDigit, AExtendedMode: boolean);
begin
ALPHABET := ALPHABET_STRING.ToCharArray;
CHARACTER_ENCODINGS := TArray<Integer>.Create($034, $121, $061, $160, $031,
$130, $070, $025, $124, $064, // 0-9
$109, $049, $148, $019, $118, $058, $00D, $10C, $04C, $01C, // A-J
$103, $043, $142, $013, $112, $052, $007, $106, $046, $016, // K-T
$181, $0C1, $1C0, $091, $190, $0D0, $085, $184, $0C4, $094, // U-*
$0A8, $0A2, $08A, $02A // $-%
);
ASTERISK_ENCODING := TCode39Reader.CHARACTER_ENCODINGS[$27];
counters := TArray<Integer>.Create();
SetLength(counters, 9);
decodeRowResult := TStringBuilder.Create();
usingCheckDigit := AUsingCheckDigit;
extendedMode := AExtendedMode;
end;
destructor TCode39Reader.Destroy;
begin
ALPHABET := nil;
CHARACTER_ENCODINGS := nil;
counters := nil;
FreeAndNil(decodeRowResult);
inherited;
end;
class function TCode39Reader.decodeExtended(encoded: string): string;
var
next, c, decodedChar: Char;
length, i: Integer;
decoded: TStringBuilder;
begin
length := encoded.length;
decoded := TStringBuilder.Create(length);
try
i := 0;
while i < length do
begin
c := encoded.Chars[i];
if (((c = '+') or (c = '$')) or ((c = '%') or (c = '/'))) then
begin
if ((i + 1) >= encoded.length) then
begin
Result := '';
exit
end;
next := encoded.Chars[(i + 1)];
decodedChar := Char(#0);
case c of
'+':
begin
if ((next >= 'A') and (next <= 'Z')) then
begin
decodedChar := Char(ord(next) + 32);
end
else
begin
exit('');
end
end;
'$':
begin
if ((next >= 'A') and (next <= 'Z')) then
begin
decodedChar := Char(ord(next) - 64);
end
else
begin
exit('');
end
end;
'%':
begin
if ((next >= 'A') and (next <= 'E')) then
decodedChar := Char(ord(next) - 38)
else if ((next >= 'F') and (next <= 'W')) then
decodedChar := Char(ord(next) - 11)
else
begin
exit('');
end;
end;
'/':
begin
if ((next >= 'A') and (next <= 'O')) then
begin
decodedChar := Char(ord(next) - 32);
end
else if (next = 'Z') then
begin
decodedChar := ':';
end
else
exit('');
end;
end;
decoded.Append(decodedChar);
Inc(i);
end
else
decoded.Append(c);
Inc(i);
end; // end loop/while
Result := decoded.ToString;
finally
decoded.Free;
end;
end;
function TCode39Reader.decodeRow(const rowNumber: Integer; const row: IBitArray;
const hints: TDictionary<TDecodeHintType, TObject>): TReadResult;
var
decodedChar: Char;
lastStart: Integer;
index, nextStart, counter, aEnd, pattern, lastPatternSize: Integer;
start: TArray<Integer>;
resultString: String;
Left, Right: Single;
resultPoints: TArray<IResultPoint>;
resultPointLeft, resultPointRight: IResultPoint;
whiteSpaceAfterEnd: Integer;
i, max, total: Integer;
begin
for index := 0 to length(counters) - 1 do
begin
counters[index] := 0;
end;
decodeRowResult.length := 0;
start := self.findAsteriskPattern(row);
if (start = nil) then
begin
Result := nil;
exit
end;
nextStart := row.getNextSet(start[1]);
aEnd := row.Size;
repeat
if (not TOneDReader.recordPattern(row, nextStart, self.counters)) then
begin
Result := nil;
exit
end;
pattern := TCode39Reader.toNarrowWidePattern(self.counters);
if (pattern < 0) then
begin
Result := nil;
exit
end;
if (not TCode39Reader.patternToChar(pattern, decodedChar)) then
begin
Result := nil;
exit
end;
self.decodeRowResult.Append(decodedChar);
lastStart := nextStart;
for counter in self.counters do
begin
Inc(nextStart, counter)
end;
nextStart := row.getNextSet(nextStart)
until (decodedChar = '*');
self.decodeRowResult.Remove((self.decodeRowResult.length - 1), 1);
lastPatternSize := 0;
for counter in self.counters do
begin
Inc(lastPatternSize, counter)
end;
whiteSpaceAfterEnd := nextStart - lastStart - lastPatternSize;
if (nextStart <> aEnd) and ((whiteSpaceAfterEnd shl 1) < lastPatternSize) then
begin
Result := nil;
exit
end;
if (usingCheckDigit) then
begin
max := self.decodeRowResult.length - 1;
total := 0;
for i := 0 to max - 1 do
begin
Inc(total, ALPHABET_STRING.indexOf(decodeRowResult.Chars[i]));
end;
if (self.decodeRowResult.Chars[max] <> ALPHABET_STRING[total mod 43]) then
begin
Result := nil;
exit
end;
self.decodeRowResult.Remove(max, self.decodeRowResult.length);
end;
if (self.decodeRowResult.length = 0) then
begin
Result := nil;
exit
end;
if extendedMode then
resultString := TCode39Reader.decodeExtended
(self.decodeRowResult.ToString())
else
resultString := decodeRowResult.ToString();
if (resultString = '') then
begin
Result := nil;
exit
end;
Left := (start[1] + start[0]) / 2;
Right := lastStart + (lastPatternSize / 2);
resultPointLeft := TResultPointHelpers.CreateResultPoint(Left, rowNumber);
resultPointRight := TResultPointHelpers.CreateResultPoint(Right, rowNumber);
resultPoints := [resultPointLeft, resultPointRight];
Result := TReadResult.Create(resultString, nil, resultPoints,
TBarcodeFormat.CODE_39);
end;
function TCode39Reader.findAsteriskPattern(row: IBitArray): TArray<Integer>;
var
i, l, patternStart, patternLength, width, counterPosition, rowOffset,
index: Integer;
isWhite: boolean;
begin
width := row.Size;
rowOffset := row.getNextSet(0);
index := 0;
while (index < length(self.counters)) do
begin
self.counters[index] := 0;
Inc(index)
end;
counterPosition := 0;
patternStart := rowOffset;
isWhite := False;
patternLength := length(counters);
for i := rowOffset to width - 1 do
begin
if (row[i] xor isWhite) then
begin
Inc(counters[counterPosition])
end
else
begin
if (counterPosition = (patternLength - 1)) then
begin
if (TCode39Reader.toNarrowWidePattern(counters)
= TCode39Reader.ASTERISK_ENCODING) then
begin
Result := TArray<Integer>.Create(patternStart, i);
exit
end;
Inc(patternStart, (counters[0] + counters[1]));
for l := 2 to patternLength - 2 do
begin
counters[l - 2] := counters[l];
end;
counters[(patternLength - 2)] := 0;
counters[(patternLength - 1)] := 0;
dec(counterPosition)
end
else
Inc(counterPosition);
counters[counterPosition] := 1;
isWhite := not isWhite
end;
end;
Result := nil;
end;
class function TCode39Reader.patternToChar(pattern: Integer;
var c: Char): boolean;
var
i: Integer;
begin
i := 0;
while (i < length(TCode39Reader.CHARACTER_ENCODINGS)) do
begin
if (TCode39Reader.CHARACTER_ENCODINGS[i] = pattern) then
begin
c := TCode39Reader.ALPHABET[i];
begin
Result := true;
exit
end
end;
Inc(i)
end;
c := '*';
Result := False;
end;
class function TCode39Reader.toNarrowWidePattern
(counters: TArray<Integer>): Integer;
var
numCounters: Integer;
maxNarrowCounter: Integer;
wideCounters: Integer;
minCounter: Integer;
counter: Integer;
totalWideCountersWidth: Integer;
pattern: Integer;
i: Integer;
begin
numCounters := length(counters);
maxNarrowCounter := 0;
repeat
minCounter := High(Integer);
for counter in counters do
begin
if (counter < minCounter) and (counter > maxNarrowCounter) then
minCounter := counter;
end;
maxNarrowCounter := minCounter;
wideCounters := 0;
totalWideCountersWidth := 0;
pattern := 0;
for i := 0 to numCounters - 1 do
begin
counter := counters[i];
if (counter > maxNarrowCounter) then
begin
pattern := pattern or (1 shl (numCounters - 1 - i));
Inc(wideCounters);
Inc(totalWideCountersWidth, counter);
end;
end;
if (wideCounters = 3) then
begin
// Found 3 wide counters, but are they close enough in width?
// We can perform a cheap, conservative check to see if any individual
// counter is more than 1.5 times the average:
i := 0;
while (i < numCounters) and (wideCounters > 0) do
begin
counter := counters[i];
if (counter > maxNarrowCounter) then
begin
dec(wideCounters);
// totalWideCountersWidth = 3 * average, so this checks if counter >= 3/2 * average
if ((counter * 2) >= totalWideCountersWidth) then
begin
Result := -1;
exit;
end;
end;
Inc(i);
end;
Result := pattern;
exit;
end;
until (wideCounters <= 3);
Result := -1;
end;
end.
@@ -0,0 +1,523 @@
{
* Copyright 2010 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Original Authors: Sean Owen
* Delphi Implementation by E. Spelt and K. Gossens
}
unit ZXing.OneD.Code93Reader;
interface
uses
System.SysUtils,
System.Generics.Collections,
Math,
ZXing.OneD.OneDReader,
ZXing.Common.BitArray,
ZXing.ReadResult,
ZXing.DecodeHintType,
ZXing.ResultPoint,
ZXing.BarcodeFormat,
ZXing.Common.Detector.MathUtils;
type
/// <summary>
/// <p>Decodes Code 93 barcodes.</p>
/// <see cref="TCode39Reader" />
/// </summary>
TCode93Reader = class sealed(TOneDReader)
private
class var ALPHABET: TArray<Char>;
class function checkChecksums(pResult: TStringBuilder): boolean; static;
class function checkOneChecksum(pResult: TStringBuilder;
checkPosition, weightMax: Integer): boolean;
class function decodeExtended(encoded: TStringBuilder): string; static;
function findAsteriskPattern(row: IBitArray): TArray<Integer>;
class function patternToChar(pattern: Integer; var c: Char)
: boolean; static;
class function toPattern(counters: TArray<Integer>): Integer; static;
const
ALPHABET_STRING
: string = '0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-. $/+%abcd*';
class var ASTERISK_ENCODING: Integer;
class var
CHARACTER_ENCODINGS: TArray<Integer>;
counters: TArray<Integer>;
decodeRowResult: TStringBuilder;
public
constructor Create;
destructor Destroy; override;
function decodeRow(const rowNumber: Integer; const row: IBitArray;
const hints: TDictionary<TDecodeHintType, TObject>): TReadResult;
override;
end;
implementation
{ Code93Reader }
constructor TCode93Reader.Create;
begin
ALPHABET := '0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-. $/+%abcd*'.ToCharArray;
CHARACTER_ENCODINGS := TArray<Integer>.Create($114, $148, $144, $142, $128,
$124, 290, $150, $112, $10A, $1A8, 420, $1A2, $194, $192, $18A, 360, $164,
$162, $134, $11A, $158, $14C, $146, 300, $116, $1B4, $1B2, $1AC, $1A6, $196,
410, $16C, $166, 310, $13A, $12E, $1D4, $1D2, $1CA, $16E, $176, 430, $126,
$1DA, 470, $132, 350);
ASTERISK_ENCODING := TCode93Reader.CHARACTER_ENCODINGS[$2F];
counters := TArray<Integer>.Create();
SetLength(counters, 6);
decodeRowResult := TStringBuilder.Create();
end;
destructor TCode93Reader.Destroy;
begin
ALPHABET := nil;
CHARACTER_ENCODINGS := nil;
counters := nil;
FreeAndNil(decodeRowResult);
inherited;
end;
class function TCode93Reader.checkChecksums(pResult: TStringBuilder): boolean;
var
length: Integer;
begin
length := pResult.length;
if (not TCode93Reader.checkOneChecksum(pResult, (length - 2), 20)) then
begin
Result := false;
exit
end;
if (not TCode93Reader.checkOneChecksum(pResult, (length - 1), 15)) then
begin
Result := false;
exit
end;
begin
Result := true;
exit
end
end;
class function TCode93Reader.checkOneChecksum(pResult: TStringBuilder;
checkPosition, weightMax: Integer): boolean;
var
weight, total, i: Integer;
begin
weight := 1;
total := 0;
i := (checkPosition - 1);
while ((i >= 0)) do
begin
inc(total, (weight * ALPHABET_STRING.IndexOf(pResult.Chars[i])));
inc(weight);
if (weight > weightMax) then
weight := 1;
dec(i)
end;
if (pResult.Chars[checkPosition] <> TCode93Reader.ALPHABET[(total mod $2F)])
then
begin
Result := false;
exit
end;
begin
Result := true;
exit
end
end;
class function TCode93Reader.decodeExtended(encoded: TStringBuilder): string;
var
next, c: Char;
decodedChar: Char;
length, i: Integer;
decoded: TStringBuilder;
label Label_0179, Label_0169, Label_014A;
begin
length := encoded.length;
decoded := TStringBuilder.Create(length);
try
i := 0;
next := Char(0);
while ((i < length)) do
begin
c := encoded.Chars[i];
if ((c < 'a') or (c > 'd')) then
goto Label_0179;
if (i < (length - 1)) then
begin
next := encoded.Chars[(i + 1)];
decodedChar := #0;
case c of
'a':
begin
if ((next < 'A') or (next > 'Z')) then
begin
Result := '';
exit
end;
decodedChar := Char(ord(next) - ord('@'));
goto Label_0169
end;
'b':
begin
if ((next < 'A') or (next > 'E')) then
break;;
decodedChar := Char(ord(next) - ord('&'));
goto Label_0169
end;
'c':
begin
if ((next < 'A') or (next > 'O')) then
goto Label_014A;
decodedChar := Char(ord(next) - ord(' '));
goto Label_0169
end;
'd':
begin
if ((next < 'A') or (next > 'Z')) then
begin
Result := '';
exit
end;
decodedChar := Char(ord(next) + ord(' '));
goto Label_0169
end;
else
begin
goto Label_0169
end;
end;
if ((next >= 'F') and (next <= 'W')) then
begin
decodedChar := Char(ord(next) - ord(' '));
goto Label_0169
end
end;
begin
Result := '';
exit
end;
Label_014A:
if (next = 'Z') then
decodedChar := ':'
else
begin
Result := '';
exit
end;
Label_0169:
decoded.Append(decodedChar);
inc(i);
continue;
Label_0179:
decoded.Append(c);
inc(i)
end;
Result := decoded.ToString;
finally
FreeAndNil(decoded);
end;
end;
function TCode93Reader.decodeRow(const rowNumber: Integer; const row: IBitArray;
const hints: TDictionary<TDecodeHintType, TObject>): TReadResult;
var
decodedChar: Char;
lastStart: Integer;
index, nextStart, counter, aEnd, pattern, lastPatternSize: Integer;
start: TArray<Integer>;
resultString: String;
Left, Right: Single;
resultPointCallback: TResultPointCallback;
obj: TObject;
resultPoints: TArray<IResultPoint>;
resultPointLeft, resultPointRight: IResultPoint;
begin
for index := 0 to length(counters) - 1 do
counters[index] := 0;
decodeRowResult.length := 0;
start := self.findAsteriskPattern(row);
if (start = nil) then
begin
Result := nil;
exit
end;
nextStart := row.getNextSet(start[1]);
aEnd := row.Size;
repeat
if (not TOneDReader.recordPattern(row, nextStart, self.counters)) then
begin
Result := nil;
exit
end;
pattern := TCode93Reader.toPattern(self.counters);
if (pattern < 0) then
begin
Result := nil;
exit
end;
if (not TCode93Reader.patternToChar(pattern, decodedChar)) then
begin
Result := nil;
exit
end;
self.decodeRowResult.Append(decodedChar);
lastStart := nextStart;
for counter in self.counters do
begin
inc(nextStart, counter)
end;
nextStart := row.getNextSet(nextStart)
until (decodedChar = '*');
self.decodeRowResult.Remove((self.decodeRowResult.length - 1), 1);
lastPatternSize := 0;
for counter in self.counters do
begin
inc(lastPatternSize, counter)
end;
if (not((nextStart <> aEnd) and row[nextStart])) then
begin
Result := nil;
exit
end;
if (self.decodeRowResult.length < 2) then
begin
Result := nil;
exit
end;
if (not TCode93Reader.checkChecksums(self.decodeRowResult)) then
begin
Result := nil;
exit
end;
self.decodeRowResult.length := self.decodeRowResult.length - 2;
resultString := TCode93Reader.decodeExtended(self.decodeRowResult);
if (resultString = '') then
begin
Result := nil;
exit
end;
Left := (start[1] + start[0]) div 2;
Right := (lastStart + lastPatternSize) / 2;
resultPointLeft := TResultPointHelpers.CreateResultPoint(Left, rowNumber);
resultPointRight := TResultPointHelpers.CreateResultPoint(Right, rowNumber);
resultPoints := [resultPointLeft, resultPointRight];
resultPointCallback := nil;
// it is a local variable: it doesn't get NIL as default value, and the following ifs do not assign a value for all possible cases
if ((hints = nil) or
(not hints.ContainsKey(TDecodeHintType.NEED_RESULT_POINT_CALLBACK))) then
resultPointCallback := nil
else
begin
obj := hints[TDecodeHintType.NEED_RESULT_POINT_CALLBACK];
if (obj is TResultPointEventObject) then
resultPointCallback := TResultPointEventObject(obj).Event;
end;
if Assigned(resultPointCallback) then
begin
resultPointCallback(resultPointLeft);
resultPointCallback(resultPointRight);
end;
Result := TReadResult.Create(resultString, nil, resultPoints,
TBarcodeFormat.CODE_93);
end;
function TCode93Reader.findAsteriskPattern(row: IBitArray): TArray<Integer>;
var
i, l, patternStart, patternLength, width, counterPosition, rowOffset,
index: Integer;
isWhite: boolean;
begin
width := row.Size;
rowOffset := row.getNextSet(0);
index := 0;
while (index < length(self.counters)) do
begin
self.counters[index] := 0;
inc(index)
end;
counterPosition := 0;
patternStart := rowOffset;
isWhite := false;
patternLength := length(counters);
for i := rowOffset to width - 1 do
begin
if (row[i] xor isWhite) then
begin
inc(counters[counterPosition])
end
else
begin
if (counterPosition = (patternLength - 1)) then
begin
if (TCode93Reader.toPattern(counters) = TCode93Reader.ASTERISK_ENCODING)
then
begin
Result := TArray<Integer>.Create(patternStart, i);
exit
end;
inc(patternStart, (counters[0] + counters[1]));
for l := 2 to patternLength - 2 do
begin
counters[l - 2] := counters[l];
end;
counters[(patternLength - 2)] := 0;
counters[(patternLength - 1)] := 0;
dec(counterPosition)
end
else
inc(counterPosition);
counters[counterPosition] := 1;
isWhite := not isWhite
end;
end;
Result := nil;
end;
class function TCode93Reader.patternToChar(pattern: Integer;
var c: Char): boolean;
var
i: Integer;
begin
i := 0;
while (i < length(TCode93Reader.CHARACTER_ENCODINGS)) do
begin
if (TCode93Reader.CHARACTER_ENCODINGS[i] = pattern) then
begin
c := TCode93Reader.ALPHABET[i];
begin
Result := true;
exit
end
end;
inc(i)
end;
c := '*';
Result := false;
end;
class function TCode93Reader.toPattern(counters: TArray<Integer>): Integer;
var
counter, max, sum, pattern, i, j, scaledShifted, scaledUnshifted: Integer;
begin
max := length(counters);
sum := 0;
for counter in counters do
begin
inc(sum, counter)
end;
pattern := 0;
i := 0;
while ((i < max)) do
begin
scaledShifted := (((counters[i] shl TOneDReader.INTEGER_MATH_SHIFT) *
9) div sum);
scaledUnshifted := TMathUtils.Asr(scaledShifted,
TOneDReader.INTEGER_MATH_SHIFT);
if ((scaledShifted and $FF) > $7F) then
inc(scaledUnshifted);
if ((scaledUnshifted < 1) or (scaledUnshifted > 4)) then
begin
Result := -1;
exit
end;
if ((i and 1) = 0) then
begin
j := 0;
while ((j < scaledUnshifted)) do
begin
pattern := ((pattern shl 1) or 1);
inc(j)
end
end
else
pattern := (pattern shl scaledUnshifted);
inc(i)
end;
Result := pattern;
end;
end.
@@ -0,0 +1,219 @@
{
* Copyright 2008 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Original Authors: dswitkin@google.com (Daniel Switkin), Sean Owen and
* alasdair@google.com (Alasdair Mackintosh)
* Delphi Implementation by K. Gossens, E. Spelt
}
unit ZXing.OneD.EAN13Reader;
interface
uses
System.SysUtils,
System.Generics.Collections,
System.Math,
ZXing.OneD.OneDReader,
ZXing.Common.BitArray,
ZXing.OneD.UPCEANReader,
ZXing.ReadResult,
ZXing.DecodeHintType,
ZXing.ResultPoint,
ZXing.BarcodeFormat;
type
/// <summary>
/// <p>Implements decoding of the EAN-13 format.</p>
/// </summary>
TEAN13Reader = class(TUPCEANReader)
private
// For an EAN-13 barcode, the first digit is represented by the parities used
// to encode the next six digits, according to the table below. For example,
// if the barcode is 5 123456 789012 then the value of the first digit is
// signified by using odd for '1', even for '2', even for '3', odd for '4',
// odd for '5', and even for '6'. See http://en.wikipedia.org/wiki/EAN-13
//
// Parity of next 6 digits
// Digit 0 1 2 3 4 5
// 0 Odd Odd Odd Odd Odd Odd
// 1 Odd Odd Even Odd Even Even
// 2 Odd Odd Even Even Odd Even
// 3 Odd Odd Even Even Even Odd
// 4 Odd Even Odd Odd Even Even
// 5 Odd Even Even Odd Odd Even
// 6 Odd Even Even Even Odd Odd
// 7 Odd Even Odd Even Odd Even
// 8 Odd Even Odd Even Even Odd
// 9 Odd Even Even Odd Even Odd
//
// Note that the encoding for '0' uses the same parity as a UPC barcode. Hence
// a UPC barcode can be converted to an EAN-13 barcode by prepending a 0.
//
// The encoding is represented by the following array, which is a bit pattern
// using Odd = 0 and Even = 1. For example, 5 is represented by:
//
// Odd Even Even Odd Odd Even
// in binary:
// 0 1 1 0 0 1 == 0x19
//
class var
FIRST_DIGIT_ENCODINGS: TArray<Integer>;
decodeMiddleCounters: TArray<Integer>;
/// <summary>
/// Based on pattern of odd-even ('L' and 'G') patterns used to encoded the explicitly-encoded
/// digits in a barcode, determines the implicitly encoded first digit and adds it to the
/// result string.
/// </summary>
/// <param name="resultString">string to insert decoded first digit into</param>
/// <param name="lgPatternFound">int whose bits indicates the pattern of odd/even L/G patterns used to</param>
/// encode digits
/// <return>-1 if first digit cannot be determined</return>
class function determineFirstDigit(const resultString: TStringBuilder;
const lgPatternFound: Integer): Boolean; static;
class procedure InitializeClass; static;
class procedure FinalizeClass; static;
protected
public
/// <summary>
/// Subclasses override this to decode the portion of a barcode between the start
/// and end guard patterns.
/// </summary>
/// <param name="row">row of black/white values to search</param>
/// <param name="startRange">start/end offset of start guard pattern</param>
/// <param name="resultString"><see cref="StringBuilder"/>to append decoded chars to</param>
/// <returns>
/// horizontal offset of first pixel after the "middle" that was decoded or -1 if decoding could not complete successfully
/// </returns>
class function DecodeMiddle(const row: IBitArray;
const startRange: TArray<Integer>; const resultString: TStringBuilder)
: Integer; override;
/// <summary>
/// Get the format of this decoder.
/// <returns>The 1D format.</returns>
/// </summary>
function BarcodeFormat: TBarcodeFormat; override;
end;
implementation
{ TEAN13Reader }
class function TEAN13Reader.DecodeMiddle(const row: IBitArray;
const startRange: TArray<Integer>;
const resultString: TStringBuilder): Integer;
var
bestMatch: Integer;
counter: Integer;
ending: Integer;
counters, middleRange: TArray<Integer>;
rowOffset, x, lgPatternFound: Integer;
begin
Result := -1;
counters := decodeMiddleCounters;
counters[0] := 0;
counters[1] := 0;
counters[2] := 0;
counters[3] := 0;
ending := row.Size;
rowOffset := startRange[1];
lgPatternFound := 0;
x := 0;
while ((x < 6) and (rowOffset < ending)) do
begin
if (not decodeDigit(row, counters, rowOffset, L_AND_G_PATTERNS, bestMatch))
then
exit;
resultString.Append( IntToStr ( bestMatch mod 10) );
for counter in counters do
Inc(rowOffset, counter);
if (bestMatch >= 10) then
lgPatternFound := lgPatternFound or (1 shl (5 - x));
Inc(x);
end;
if (not determineFirstDigit(resultString, lgPatternFound)) then
exit;
middleRange := findGuardPattern(row, rowOffset, true, MIDDLE_PATTERN);
if (middleRange = nil) then
exit;
rowOffset := middleRange[1];
x := 0;
while ((x < 6) and (rowOffset < ending)) do
begin
if (not decodeDigit(row, counters, rowOffset, L_PATTERNS, bestMatch)) then
exit;
resultString.Append(IntToStr(bestMatch));
for counter in counters do
Inc(rowOffset, counter);
Inc(x);
end;
Result := rowOffset;
end;
function TEAN13Reader.BarcodeFormat: TBarcodeFormat;
begin
Result := TBarcodeFormat.EAN_13;
end;
class function TEAN13Reader.determineFirstDigit(const resultString
: TStringBuilder; const lgPatternFound: Integer): Boolean;
var
d: Integer;
begin
Result := false;
for d := 0 to Pred(10) do
begin
if (lgPatternFound = FIRST_DIGIT_ENCODINGS[d]) then
begin
resultString.Insert(0, IntToStr(d));
Result := true;
break;
end;
end;
end;
class procedure TEAN13Reader.InitializeClass;
begin
FIRST_DIGIT_ENCODINGS := TArray<Integer>.Create($00, $0B, $0D, $0E, $13, $19,
$1C, $15, $16, $1A);
SetLength(decodeMiddleCounters, 4);
end;
class procedure TEAN13Reader.FinalizeClass;
begin
FIRST_DIGIT_ENCODINGS := nil;
decodeMiddleCounters := nil;
end;
initialization
TEAN13Reader.InitializeClass;
finalization
TEAN13Reader.FinalizeClass;
end.
@@ -0,0 +1,148 @@
{
* Copyright 2008 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Original Authors: dswitkin@google.com (Daniel Switkin), Sean Owen and
* alasdair@google.com (Alasdair Mackintosh)
*
* Delphi Implementation by E. Spelt
}
unit ZXing.OneD.EAN8Reader;
interface
uses
System.SysUtils,
System.Generics.Collections,
System.Math,
ZXing.OneD.OneDReader,
ZXing.Common.BitArray,
ZXing.OneD.UPCEANReader,
ZXing.ReadResult,
ZXing.DecodeHintType,
ZXing.ResultPoint,
ZXing.BarcodeFormat;
type
/// <summary>
/// <p>Implements decoding of the EAN-8 format.</p>
/// </summary>
TEAN8Reader = class(TUPCEANReader)
private
class var DecodeMiddleCounters: TArray<Integer>;
class procedure DoInitialize();
class procedure DoFinalize();
public
class function DecodeMiddle(const row: IBitArray;
const startRange: TArray<Integer>; const resultString: TStringBuilder)
: Integer; override;
function BarcodeFormat: TBarcodeFormat; override;
end;
implementation
function TEAN8Reader.BarcodeFormat: TBarcodeFormat;
begin
result := TBarcodeFormat.EAN_8;
end;
class procedure TEAN8Reader.DoFinalize;
begin
DecodeMiddleCounters := nil;
end;
class procedure TEAN8Reader.DoInitialize;
begin
SetLength(DecodeMiddleCounters, 4);
end;
class function TEAN8Reader.DecodeMiddle(const row: IBitArray;
const startRange: TArray<Integer>;
const resultString: TStringBuilder): Integer;
var
ending, rowOffset, x, bestMatch: Integer;
counter: Integer;
counters, middleRange: TArray<Integer>;
begin
counters := self.DecodeMiddleCounters;
counters[0] := 0;
counters[1] := 0;
counters[2] := 0;
counters[3] := 0;
ending := row.Size;
rowOffset := startRange[1];
x := 0;
while (((x < 4) and (rowOffset < ending))) do
begin
if (not TUPCEANReader.decodeDigit(row, counters, rowOffset,
TUPCEANReader.L_PATTERNS, bestMatch)) then
begin
result := -1;
exit
end;
resultString.Append(IntToStr(bestMatch));
for counter in counters do
begin
inc(rowOffset, counter)
end;
inc(x)
end;
middleRange := TUPCEANReader.findGuardPattern(row, rowOffset, true,
TUPCEANReader.MIDDLE_PATTERN);
if (middleRange = nil) then
begin
result := -1;
exit
end;
rowOffset := middleRange[1];
x := 0;
while (((x < 4) and (rowOffset < ending))) do
begin
if (not TUPCEANReader.decodeDigit(row, counters, rowOffset,
TUPCEANReader.L_PATTERNS, bestMatch)) then
begin
result := -1;
exit
end;
resultString.Append(IntToStr(bestMatch));
for counter in counters do
begin
inc(rowOffset, counter)
end;
inc(x)
end;
result := rowOffset;
end;
initialization
TEAN8Reader.DoInitialize;
finalization
TEAN8Reader.DoFinalize;
end.
@@ -0,0 +1,230 @@
{
* Copyright 2010 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Original Author: Sean Owen
* Delphi Implementation by K. Gossens
}
unit ZXing.OneD.EANManufacturerOrgSupport;
interface
uses
System.SysUtils,
System.Classes,
System.Generics.Collections,
System.Math,
ZXing.OneD.UPCEANExtension2Support,
ZXing.OneD.UPCEANExtension5Support,
ZXing.Reader,
ZXing.BinaryBitmap,
ZXing.ReadResult,
ZXing.DecodeHintType,
ZXing.ResultMetadataType,
ZXing.ResultPoint,
ZXing.Common.BitArray,
ZXing.Common.Detector.MathUtils;
type
// <summary>
/// Records EAN prefix to GS1 Member Organization, where the member organization
/// correlates strongly with a country. This is an imperfect means of identifying
/// a country of origin by EAN-13 barcode value. See
/// <a href="http://en.wikipedia.org/wiki/List_of_GS1_country_codes">
/// http://en.wikipedia.org/wiki/List_of_GS1_country_codes</a>.
/// </summary>
TEANManufacturerOrgSupport = class sealed
private
var
ranges: TList<TArray<Integer>>;
countryIdentifiers: TStringList;
procedure add(const range: TArray<Integer>; const id: string);
procedure initIfNeeded;
public
constructor Create;
destructor Destroy; override;
function lookupCountryIdentifier(const productCode: String): String;
end;
implementation
{ TEANManufacturerOrgSupport }
constructor TEANManufacturerOrgSupport.Create;
begin
ranges := TList < TArray < Integer >>.Create;
countryIdentifiers := TStringList.Create;
end;
destructor TEANManufacturerOrgSupport.Destroy;
begin
countryIdentifiers.Free;
ranges.Free;
inherited;
end;
function TEANManufacturerOrgSupport.lookupCountryIdentifier(const productCode
: String): String;
var
i, prefix, max: Integer;
range: TArray<Integer>;
start, ending: Integer;
begin
Result := '';
initIfNeeded;
prefix := Integer.Parse(productCode.Substring(0, 3));
max := ranges.Count;
for i := 0 to Pred(max) do
begin
range := ranges[i];
start := range[0];
if (prefix < start) then
exit;
if (Length(range) = 1) then
ending := start
else
ending := range[1];
if (prefix <= ending) then
begin
Result := countryIdentifiers[i];
break;
end;
end;
end;
procedure TEANManufacturerOrgSupport.add(const range: TArray<Integer>;
const id: string);
begin
ranges.add(range);
countryIdentifiers.add(id);
end;
procedure TEANManufacturerOrgSupport.initIfNeeded;
begin
if (ranges.Count = 0) then
begin
add(TArray<Integer>.Create(0, 19), 'US/CA');
add(TArray<Integer>.Create(30, 39), 'US');
add(TArray<Integer>.Create(60, 139), 'US/CA');
add(TArray<Integer>.Create(300, 379), 'FR');
add(TArray<Integer>.Create(380), 'BG');
add(TArray<Integer>.Create(383), 'SI');
add(TArray<Integer>.Create(385), 'HR');
add(TArray<Integer>.Create(387), 'BA');
add(TArray<Integer>.Create(400, 440), 'DE');
add(TArray<Integer>.Create(450, 459), 'JP');
add(TArray<Integer>.Create(460, 469), 'RU');
add(TArray<Integer>.Create(471), 'TW');
add(TArray<Integer>.Create(474), 'EE');
add(TArray<Integer>.Create(475), 'LV');
add(TArray<Integer>.Create(476), 'AZ');
add(TArray<Integer>.Create(477), 'LT');
add(TArray<Integer>.Create(478), 'UZ');
add(TArray<Integer>.Create(479), 'LK');
add(TArray<Integer>.Create(480), 'PH');
add(TArray<Integer>.Create(481), 'BY');
add(TArray<Integer>.Create(482), 'UA');
add(TArray<Integer>.Create(484), 'MD');
add(TArray<Integer>.Create(485), 'AM');
add(TArray<Integer>.Create(486), 'GE');
add(TArray<Integer>.Create(487), 'KZ');
add(TArray<Integer>.Create(489), 'HK');
add(TArray<Integer>.Create(490, 499), 'JP');
add(TArray<Integer>.Create(500, 509), 'GB');
add(TArray<Integer>.Create(520), 'GR');
add(TArray<Integer>.Create(528), 'LB');
add(TArray<Integer>.Create(529), 'CY');
add(TArray<Integer>.Create(531), 'MK');
add(TArray<Integer>.Create(535), 'MT');
add(TArray<Integer>.Create(539), 'IE');
add(TArray<Integer>.Create(540, 549), 'BE/LU');
add(TArray<Integer>.Create(560), 'PT');
add(TArray<Integer>.Create(569), 'IS');
add(TArray<Integer>.Create(570, 579), 'DK');
add(TArray<Integer>.Create(590), 'PL');
add(TArray<Integer>.Create(594), 'RO');
add(TArray<Integer>.Create(599), 'HU');
add(TArray<Integer>.Create(600, 601), 'ZA');
add(TArray<Integer>.Create(603), 'GH');
add(TArray<Integer>.Create(608), 'BH');
add(TArray<Integer>.Create(609), 'MU');
add(TArray<Integer>.Create(611), 'MA');
add(TArray<Integer>.Create(613), 'DZ');
add(TArray<Integer>.Create(616), 'KE');
add(TArray<Integer>.Create(618), 'CI');
add(TArray<Integer>.Create(619), 'TN');
add(TArray<Integer>.Create(621), 'SY');
add(TArray<Integer>.Create(622), 'EG');
add(TArray<Integer>.Create(624), 'LY');
add(TArray<Integer>.Create(625), 'JO');
add(TArray<Integer>.Create(626), 'IR');
add(TArray<Integer>.Create(627), 'KW');
add(TArray<Integer>.Create(628), 'SA');
add(TArray<Integer>.Create(629), 'AE');
add(TArray<Integer>.Create(640, 649), 'FI');
add(TArray<Integer>.Create(690, 695), 'CN');
add(TArray<Integer>.Create(700, 709), 'NO');
add(TArray<Integer>.Create(729), 'IL');
add(TArray<Integer>.Create(730, 739), 'SE');
add(TArray<Integer>.Create(740), 'GT');
add(TArray<Integer>.Create(741), 'SV');
add(TArray<Integer>.Create(742), 'HN');
add(TArray<Integer>.Create(743), 'NI');
add(TArray<Integer>.Create(744), 'CR');
add(TArray<Integer>.Create(745), 'PA');
add(TArray<Integer>.Create(746), 'DO');
add(TArray<Integer>.Create(750), 'MX');
add(TArray<Integer>.Create(754, 755), 'CA');
add(TArray<Integer>.Create(759), 'VE');
add(TArray<Integer>.Create(760, 769), 'CH');
add(TArray<Integer>.Create(770), 'CO');
add(TArray<Integer>.Create(773), 'UY');
add(TArray<Integer>.Create(775), 'PE');
add(TArray<Integer>.Create(777), 'BO');
add(TArray<Integer>.Create(779), 'AR');
add(TArray<Integer>.Create(780), 'CL');
add(TArray<Integer>.Create(784), 'PY');
add(TArray<Integer>.Create(785), 'PE');
add(TArray<Integer>.Create(786), 'EC');
add(TArray<Integer>.Create(789, 790), 'BR');
add(TArray<Integer>.Create(800, 839), 'IT');
add(TArray<Integer>.Create(840, 849), 'ES');
add(TArray<Integer>.Create(850), 'CU');
add(TArray<Integer>.Create(858), 'SK');
add(TArray<Integer>.Create(859), 'CZ');
add(TArray<Integer>.Create(860), 'YU');
add(TArray<Integer>.Create(865), 'MN');
add(TArray<Integer>.Create(867), 'KP');
add(TArray<Integer>.Create(868, 869), 'TR');
add(TArray<Integer>.Create(870, 879), 'NL');
add(TArray<Integer>.Create(880), 'KR');
add(TArray<Integer>.Create(885), 'TH');
add(TArray<Integer>.Create(888), 'SG');
add(TArray<Integer>.Create(890), 'IN');
add(TArray<Integer>.Create(893), 'VN');
add(TArray<Integer>.Create(896), 'PK');
add(TArray<Integer>.Create(899), 'ID');
add(TArray<Integer>.Create(900, 919), 'AT');
add(TArray<Integer>.Create(930, 939), 'AU');
add(TArray<Integer>.Create(940, 949), 'AZ');
add(TArray<Integer>.Create(955), 'MY');
add(TArray<Integer>.Create(958), 'MO');
end;
end;
end.
@@ -0,0 +1,497 @@
{
* Copyright 2008 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Original Author: kevin.osullivan@sita.aero, SITA Lab.
* Delphi Implementation by E. Spelt and K. Gossens
}
unit ZXing.OneD.ITFReader;
interface
uses
System.SysUtils,
System.Generics.Collections,
Math,
ZXing.OneD.OneDReader,
ZXing.Common.BitArray,
ZXing.ReadResult,
ZXing.DecodeHintType,
ZXing.ResultPoint,
ZXing.BarcodeFormat,
ZXing.Helpers;
type
/// <summary>
/// <p>Implements decoding of the ITF format, or Interleaved Two of Five.</p>
///
/// <p>This Reader will scan ITF barcodes of certain lengths only.
/// At the moment it reads length 6, 8, 10, 12, 14, 16, 18, 20, 24, 44 and 48 as these have appeared "in the wild". Not all
/// lengths are scanned, especially shorter ones, to avoid false positives. This in turn is due to a lack of
/// required checksum function.</p>
///
/// <p>The checksum is optional and is not applied by this Reader. The consumer of the decoded
/// value will have to apply a checksum if required.</p>
///
/// <p><a href="http://en.wikipedia.org/wiki/Interleaved_2_of_5">http://en.wikipedia.org/wiki/Interleaved_2_of_5</a>
/// is a great reference for Interleaved 2 of 5 information.</p>
/// </summary>
TITFReader = class(TOneDReader)
const
LARGEST_DEFAULT_ALLOWED_LENGTH: Integer = 14;
N: Integer = 1;
W: Integer = 3;
private
class var PATTERNS: TArray<TArray<Integer>>;
class var END_PATTERN_REVERSED: TArray<Integer>;
class var MAX_AVG_VARIANCE: Integer;
class var MAX_INDIVIDUAL_VARIANCE: Integer;
class var DEFAULT_ALLOWED_LENGTHS: TArray<Integer>;
class var
START_PATTERN: TArray<Integer>;
narrowLineWidth: Integer;
class function decodeDigit(counters: TArray<Integer>;
out bestMatch: Integer): boolean; static;
function decodeEnd(row: IBitArray): TArray<Integer>;
class function skipWhiteSpace(row: IBitArray): Integer; static;
class function findGuardPattern(row: IBitArray; rowOffset: Integer;
pattern: TArray<Integer>): TArray<Integer>; static;
function validateQuietZone(row: IBitArray; startPattern: Integer): boolean;
function decodeStart(row: IBitArray): TArray<Integer>;
class function decodeMiddle(row: IBitArray;
payloadStart, payloadEnd: Integer; SBResult: TStringBuilder)
: boolean; static;
class procedure ClassInit();
public
function decodeRow(const rowNumber: Integer; const row: IBitArray;
const hints: TDictionary<TDecodeHintType, TObject>): TReadResult; override;
end;
implementation
uses
ZXing.Common.Detector.MathUtils;
{ TITFReader }
class procedure TITFReader.ClassInit();
begin
MAX_AVG_VARIANCE := Floor(PATTERN_MATCH_RESULT_SCALE_FACTOR * 0.42);
MAX_INDIVIDUAL_VARIANCE := Floor(PATTERN_MATCH_RESULT_SCALE_FACTOR * 0.78);
DEFAULT_ALLOWED_LENGTHS := [6, 8, 10, 12, 14];
START_PATTERN := [N, N, N, N];
END_PATTERN_REVERSED := [N, N, W];
PATTERNS := [[N, N, W, W, N], // 0
[W, N, N, N, W], // 1
[N, W, N, N, W], // 2
[W, W, N, N, N], // 3
[N, N, W, N, W], // 4
[W, N, W, N, N], // 5
[N, W, W, N, N], // 6
[N, N, N, W, W], // 7
[W, N, N, W, N], // 8
[N, W, N, W, N]]; // 9
end;
function TITFReader.decodeRow(const rowNumber: Integer; const row: IBitArray;
const hints: TDictionary<TDecodeHintType, TObject>): TReadResult;
var
allowedLength: Integer;
startRange: TArray<Integer>;
endRange: TArray<Integer>;
stringResult: string;
allowedLengths: TArray<Integer>;
maxAllowedLength: Integer;
len: Integer;
lengthOK: boolean;
SBResult: TStringBuilder;
resultPointCallback: TResultPointCallback;
obj: TObject;
resultPoints: TArray<IResultPoint>;
resultPointLeft,
resultPointRight: IResultPoint;
begin
startRange := decodeStart(row);
if (startRange = nil) then
begin
Exit(nil);
end;
endRange := self.decodeEnd(row);
if (endRange = nil) then
begin
Exit(nil);
end;
SBResult := TStringBuilder.Create(20);
if (not decodeMiddle(row, startRange[1], endRange[0], SBResult)) then
begin
FreeAndNil(sbResult);
Exit(nil);
end;
stringResult := SBResult.ToString();
FreeAndNil(sbResult);
allowedLengths := nil;
maxAllowedLength := LARGEST_DEFAULT_ALLOWED_LENGTH;
if ((hints <> nil) and hints.ContainsKey(ZXing.DecodeHintType.ALLOWED_LENGTHS)) then
begin
allowedLengths := TArray<Integer>(hints[ZXing.DecodeHintType.ALLOWED_LENGTHS]);
maxAllowedLength := 0
end;
if (allowedLengths = nil) then
begin
allowedLengths := DEFAULT_ALLOWED_LENGTHS;
maxAllowedLength := LARGEST_DEFAULT_ALLOWED_LENGTH;
end;
len := Length(stringResult);
lengthOK := (len > LARGEST_DEFAULT_ALLOWED_LENGTH);
if (not lengthOK) then
begin
for allowedLength in allowedLengths do
begin
if (len = allowedLength) then
begin
lengthOK := true;
break;
end;
if (allowedLength > maxAllowedLength) then
begin
maxAllowedLength := allowedLength;
end;
end;
if ((not lengthOK) and (len > maxAllowedLength)) then
begin
lengthOK := true;
end;
if (not lengthOK) then
begin
Exit(nil);
end
end;
resultPointLeft := TResultPointHelpers.CreateResultPoint(startRange[1], rowNumber);
resultPointRight := TResultPointHelpers.CreateResultPoint(endRange[0], rowNumber);
resultPoints := [resultPointLeft, resultPointRight];
resultPointCallback := nil; // had to add this initialization because the following if/else construct does not assign a value
// for all possible cases. Being resultPointCallback a local variable it is not initialized by default to null,
// so you could get unpredictable results
if ((hints = nil) or
(not hints.ContainsKey(TDecodeHintType.NEED_RESULT_POINT_CALLBACK)))
then
resultPointCallback := nil
else
begin
obj := hints[TDecodeHintType.NEED_RESULT_POINT_CALLBACK];
if (obj is TResultPointEventObject)
then
resultPointCallback := TResultPointEventObject(obj).Event;
end;
if Assigned(resultPointCallback) then
begin
resultPointCallback(resultPointLeft);
resultPointCallback(resultPointRight);
end;
Result := TReadResult.Create(stringResult, nil, resultPoints,
TBarcodeFormat.ITF);
end;
class function TITFReader.decodeDigit(counters: TArray<Integer>;
out bestMatch: Integer): boolean;
var
bestVariance: Integer;
max: Integer;
i: Integer;
pattern: TArray<Integer>;
variance: Integer;
begin
bestVariance := MAX_AVG_VARIANCE;
bestMatch := -1;
max := Length(PATTERNS);
i := 0;
while ((i < max)) do
begin
pattern := PATTERNS[i];
variance := PatternMatchVariance(counters, pattern,
MAX_INDIVIDUAL_VARIANCE);
if (variance < bestVariance) then
begin
bestVariance := variance;
bestMatch := i
end;
inc(i)
end;
Result := (bestMatch >= 0);
end;
function TITFReader.decodeStart(row: IBitArray): TArray<Integer>;
var
endStart: Integer;
startPattern: TArray<Integer>;
begin
endStart := skipWhiteSpace(row);
if (endStart < 0) then
begin
Exit(nil);
end;
startPattern := findGuardPattern(row, endStart, START_PATTERN);
if (startPattern = nil) then
begin
Exit(nil);
end;
narrowLineWidth := TMathUtils.Asr(startPattern[1] - startPattern[0], 2);
if (not validateQuietZone(row, startPattern[0])) then
begin
Exit(nil);
end;
Result := startPattern;
end;
class function TITFReader.decodeMiddle(row: IBitArray;
payloadStart, payloadEnd: Integer; SBResult: TStringBuilder): boolean;
var
bestMatch: Integer;
counterDigit: Integer;
counterDigitPair: TArray<Integer>;
counterBlack: TArray<Integer>;
counterWhite: TArray<Integer>;
k: Integer;
twoK: Integer;
begin
SetLength(counterDigitPair, 10);
SetLength(counterBlack, 5);
SetLength(counterWhite, 5);
while ((payloadStart < payloadEnd)) do
begin
if (not RecordPattern(row, payloadStart, counterDigitPair)) then
begin
Exit(false);
end;
k := 0;
while ((k < 5)) do
begin
twoK := (k shl 1);
counterBlack[k] := counterDigitPair[twoK];
counterWhite[k] := counterDigitPair[(twoK + 1)];
inc(k)
end;
if (not decodeDigit(counterBlack, bestMatch)) then // @(bestMatch))) then
begin
Exit(false);
end;
SBResult.Append(char($30 + bestMatch));
if (not decodeDigit(counterWhite, bestMatch)) then // @(bestMatch))) then
begin
Exit(false);
end;
SBResult.Append(char($30 + bestMatch));
for counterDigit in counterDigitPair do
begin
inc(payloadStart, counterDigit);
end
end;
Result := true;
end;
function TITFReader.decodeEnd(row: IBitArray): TArray<Integer>;
var
endStart: Integer;
endPattern: TArray<Integer>;
temp: Integer;
begin
row.reverse;
endStart := skipWhiteSpace(row);
if (endStart < 0) then
begin
Exit(nil);
end;
// !!
endPattern := findGuardPattern(row, endStart, END_PATTERN_REVERSED);
if (endPattern = nil) then
begin
row.reverse;
Exit(nil);
end;
if (not validateQuietZone(row, endPattern[0])) then
begin
row.reverse;
Exit(nil);
end;
temp := endPattern[0];
endPattern[0] := row.Size - endPattern[1];
endPattern[1] := row.Size - temp;
row.reverse;
Result := endPattern;
end;
class function TITFReader.findGuardPattern(row: IBitArray; rowOffset: Integer;
pattern: TArray<Integer>): TArray<Integer>;
var
patternLength: Integer;
counters: TArray<Integer>;
width: Integer;
isWhite: boolean;
counterPosition: Integer;
patternStart: Integer;
x: Integer;
begin
patternLength := Length(pattern);
counters := TArray<Integer>.Create();
SetLength(counters, patternLength);
width := row.Size;
isWhite := false;
counterPosition := 0;
patternStart := rowOffset;
x := rowOffset;
while ((x < width)) do
begin
if (row[x] xor isWhite) then
begin
inc(counters[counterPosition]);
end
else
begin
if (counterPosition = (patternLength - 1)) then
begin
if (PatternMatchVariance(counters, pattern, MAX_INDIVIDUAL_VARIANCE) <
MAX_AVG_VARIANCE) then
begin
Result := [patternStart, x];
Exit(Result);
end;
inc(patternStart, (counters[0] + counters[1]));
counters := TArray.CopyInSameArray(counters, 2, patternLength - 2);
counters[(patternLength - 2)] := 0;
counters[(patternLength - 1)] := 0;
dec(counterPosition);
end
else
begin
inc(counterPosition);
end;
counters[counterPosition] := 1;
isWhite := not isWhite
end;
inc(x);
end;
Result := nil;
end;
class function TITFReader.skipWhiteSpace(row: IBitArray): Integer;
var
width: Integer;
endStart: Integer;
begin
width := row.Size;
endStart := row.getNextSet(0);
if (endStart = width) then
begin
Result := -1;
end
else
begin
Result := endStart;
end
end;
function TITFReader.validateQuietZone(row: IBitArray;
startPattern: Integer): boolean;
var
quietCount: Integer;
i: Integer;
begin
quietCount := (self.narrowLineWidth * 10);
if (quietCount >= startPattern) then
begin
quietCount := startPattern;
end;
i := (startPattern - 1);
while (((quietCount > 0) and (i >= 0))) do
begin
if (row[i]) then
begin
break;
end;
dec(quietCount);
dec(i)
end;
if (quietCount <> 0) then
begin
Exit(false);
end;
Result := true;
end;
initialization
TITFReader.ClassInit();
end.
@@ -0,0 +1,499 @@
{
* Copyright 2007 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Original Authors: dswitkin@google.com (Daniel Switkin) and Sean Owen
* Delphi Implementation by E. Spelt and K. Gossens
}
unit ZXing.OneD.OneDReader;
interface
uses
System.SysUtils,
System.Generics.Collections,
Math,
ZXing.Reader,
ZXing.BinaryBitmap,
ZXing.ReadResult,
ZXing.DecodeHintType,
ZXing.ResultMetadataType,
ZXing.ResultPoint,
ZXing.Common.BitArray,
ZXing.Common.Detector.MathUtils;
type
/// <summary>
/// Encapsulates functionality and implementation that is common to all families
/// of one-dimensional barcodes.
/// </summary>
TOneDReader = class(TInterfacedObject, IReader)
private
/// <summary>
/// We're going to examine rows from the middle outward, searching alternately above and below the
/// middle, and farther out each time. rowStep is the number of rows between each successive
/// attempt above and below the middle. So we'd scan row middle, then middle - rowStep, then
/// middle + rowStep, then middle - (2 * rowStep), etc.
/// rowStep is bigger as the image is taller, but is always at least 1. We've somewhat arbitrarily
/// decided that moving up and down by about 1/16 of the image is pretty good; we try more of the
/// image if "trying harder".
/// </summary>
/// <param name="image">The image to decode</param>
/// <param name="hints">Any hints that were requested</param>
/// <returns>The contents of the decoded barcode</returns>
function doDecode(const image: TBinaryBitmap;
hints: TDictionary<TDecodeHintType, TObject>): TReadResult;
class procedure InitializeClass; static;
protected
class var INTEGER_MATH_SHIFT: Integer;
class var PATTERN_MATCH_RESULT_SCALE_FACTOR: Integer;
/// <summary>
/// Determines how closely a set of observed counts of runs of black/white values matches a given
/// target pattern. This is reported as the ratio of the total variance from the expected pattern
/// proportions across all pattern elements, to the length of the pattern.
/// </summary>
/// <param name="counters">observed counters</param>
/// <param name="pattern">expected pattern</param>
/// <param name="maxIndividualVariance">The most any counter can differ before we give up</param>
/// <returns>ratio of total variance between counters and pattern compared to total pattern size,
/// where the ratio has been multiplied by 256. So, 0 means no variance (perfect match); 256 means
/// the total variance between counters and patterns equals the pattern length, higher values mean
/// even more variance</returns>
class function patternMatchVariance(counters, pattern: TArray<Integer>;
maxIndividualVariance: Integer): Integer; static;
/// <summary>
/// Records the pattern in reverse.
/// </summary>
/// <param name="row">The row.</param>
/// <param name="start">The start.</param>
/// <param name="counters">The counters.</param>
/// <returns></returns>
class function RecordPatternInReverse(row: IBitArray; start: Integer;
counters: TArray<Integer>): Boolean; Static;
/// <summary>
/// Records the size of successive runs of white and black pixels in a row, starting at a given point.
/// The values are recorded in the given array, and the number of runs recorded is equal to the size
/// of the array. If the row starts on a white pixel at the given start point, then the first count
/// recorded is the run of white pixels starting from that point; likewise it is the count of a run
/// of black pixels if the row begin on a black pixels at that point.
/// </summary>
/// <param name="row">row to count from</param>
/// <param name="start">offset into row to start at</param>
/// <param name="counters">array into which to record counts</param>
class function recordPattern(row: IBitArray; start: Integer;
counters: TArray<Integer>; numCounters: Integer): Boolean;
overload; static;
public
/// <summary>
/// Resets any internal state the implementation has after a decode, to prepare it
/// for reuse.
/// </summary>
procedure reset(); virtual;
/// <summary>
/// Locates and decodes a barcode in some format within an image.
/// </summary>
/// <param name="image">image of barcode to decode</param>
/// <returns>
/// String which the barcode encodes
/// </returns>
function decode(const image: TBinaryBitmap): TReadResult; overload;
/// <summary>
/// Locates and decodes a barcode in some format within an image. This method also accepts
/// hints, each possibly associated to some data, which may help the implementation decode.
/// Note that we don't try rotation without the try harder flag, even if rotation was supported.
/// </summary>
/// <param name="image">image of barcode to decode</param>
/// <param name="hints">passed as a <see cref="IDictionary{TKey, TValue}"/> from <see cref="DecodeHintType"/>
/// to arbitrary data. The
/// meaning of the data depends upon the hint type. The implementation may or may not do
/// anything with these hints.</param>
/// <returns>
/// String which the barcode encodes
/// </returns>
function decode(const image: TBinaryBitmap;
hints: TDictionary<TDecodeHintType, TObject>): TReadResult;
overload; virtual;
/// <summary>
/// Records the size of successive runs of white and black pixels in a row, starting at a given point.
/// The values are recorded in the given array, and the number of runs recorded is equal to the size
/// of the array. If the row starts on a white pixel at the given start point, then the first count
/// recorded is the run of white pixels starting from that point; likewise it is the count of a run
/// of black pixels if the row begin on a black pixels at that point.
/// </summary>
/// <param name="row">row to count from</param>
/// <param name="start">offset into row to start at</param>
/// <param name="counters">array into which to record counts</param>
class function recordPattern(row: IBitArray; start: Integer;
counters: TArray<Integer>): Boolean; overload; static;
/// <summary>
/// Attempts to decode a one-dimensional barcode format given a single row of
/// an image.
/// </summary>
/// <param name="rowNumber">row number from top of the row</param>
/// <param name="row">the black/white pixel data of the row</param>
/// <param name="hints">decode hints</param>
/// <returns>
/// <see cref="Result"/>containing encoded string and start/end of barcode
/// </returns>
function decodeRow(const rowNumber: Integer; const row: IBitArray;
const hints: TDictionary<TDecodeHintType, TObject>): TReadResult;
virtual; abstract;
end;
implementation
{ TOneDReader }
function TOneDReader.decode(const image: TBinaryBitmap): TReadResult;
begin
Result := decode(image, nil);
end;
class procedure TOneDReader.InitializeClass();
begin
INTEGER_MATH_SHIFT := 8;
PATTERN_MATCH_RESULT_SCALE_FACTOR := (1 shl INTEGER_MATH_SHIFT);
end;
function TOneDReader.decode(const image: TBinaryBitmap;
hints: TDictionary<TDecodeHintType, TObject>): TReadResult;
var
tryHarder, tryHarderWithoutRotation: Boolean;
rotatedImage: TBinaryBitmap;
metadata: TResultMetadata;
orientation, height, i, l: Integer;
points: TArray<IResultPoint>;
begin
Result := doDecode(image, hints);
if (Result = nil) then
begin
Exit;
end;
tryHarder := (hints <> nil) and
(hints.ContainsKey(ZXing.DecodeHintType.TRY_HARDER));
tryHarderWithoutRotation := (hints <> nil) and
(hints.ContainsKey(ZXing.DecodeHintType.TRY_HARDER_WITHOUT_ROTATION));
if (tryHarder and ((not tryHarderWithoutRotation) and image.RotateSupported))
then
begin
rotatedImage := image.rotateCounterClockwise();
Result := doDecode(rotatedImage, hints);
if (Result = nil) then
begin
Exit;
end;
// Record that we found it rotated 90 degrees CCW / 270 degrees CW
metadata := Result.ResultMetadata;
orientation := 270;
if ((metadata <> nil) and metadata.ContainsKey
(ZXing.ResultMetadataType.orientation)) then
begin
// But if we found it reversed in doDecode(), add in that result here:
orientation :=
(orientation + (metadata[ZXing.ResultMetadataType.orientation]
as IIntegerMetadata).Value) mod 360;
end;
Result.putMetadata(ZXing.ResultMetadataType.orientation,
TResultMetadata.CreateIntegerMetadata(orientation));
// Update result points
points := Result.ResultPoints;
if (points <> nil) then
begin
height := rotatedImage.height;
l := Length(points) - 1;
for i := 0 to l do
begin
points[i] := TResultPointHelpers.CreateResultPoint
(height - points[i].Y - 1, points[i].X);
end;
end;
end;
end;
function TOneDReader.doDecode(const image: TBinaryBitmap;
hints: TDictionary<TDecodeHintType, TObject>): TReadResult;
var
attempt, X, rowNumber, rowStepsAboveOrBelow, width, height, middle, rowStep,
maxLines: Integer;
row: IBitArray;
isAbove, hadResultPointCallBack: Boolean;
ReadResult: TReadResult;
points: TArray<IResultPoint>;
obj: TObject;
needsCallBack : boolean;
begin
needsCallBack := (hints <> nil) and (hints.ContainsKey(ZXing.DecodeHintType.NEED_RESULT_POINT_CALLBACK));
width := image.width;
height := image.height;
row := TBitArrayHelpers.CreateBitArray(width);
// row is a interfaced object: we don't need to free it explicitly
middle := TMathUtils.Asr(height, 1);
rowStep := 5;
maxLines := height; // Look at the whole image, not just the center
for X := 0 to maxLines - 1 do
begin
// Scanning from the middle out. Determine which row we're looking at next:
rowStepsAboveOrBelow := TMathUtils.Asr((X + 1), 1);
isAbove := (X and $01) = 0; // i.e. is x even?
if (not isAbove) then
begin
rowStepsAboveOrBelow := rowStepsAboveOrBelow * -1;
end;
rowNumber := middle + rowStep * rowStepsAboveOrBelow;
if ((rowNumber < 0) or (rowNumber >= height)) then
begin
// Oops, if we run off the top or bottom, stop
break;
end;
// Estimate black point for this row and load it:
row := image.getBlackRow(rowNumber, row);
if (row = nil) then
begin
continue;
end;
// While we have the image data in a BitArray, it's fairly cheap to reverse it in place to
// handle decoding upside down barcodes.
// for attempt := 0 to (attempt < 2) do
for attempt := 0 to 1 do
begin
hadResultPointCallBack := false;
if (attempt = 1) then
begin
// trying again?
row.Reverse();
// This means we will only ever draw result points *once* in the life of this method
// since we want to avoid drawing the wrong points after flipping the row, and,
// don't want to clutter with noise from every single row scan -- just the scans
// that start on the center line.
if needsCallBack then
begin
hints.TryGetValue
(ZXing.DecodeHintType.NEED_RESULT_POINT_CALLBACK, obj);
hints.Remove(ZXing.DecodeHintType.NEED_RESULT_POINT_CALLBACK);
hadResultPointCallBack := true;
end;
end;
// Look for a barcode
ReadResult := decodeRow(rowNumber, row, hints);
if hadResultPointCallBack then
begin
hints.Add(ZXing.DecodeHintType.NEED_RESULT_POINT_CALLBACK, obj);
end;
if (ReadResult = nil) then
begin
continue;
end;
// We found our barcode
if (attempt = 1) then
begin
// But it was upside down, so note that
// ReadResult.putMetadata(ResultMetadataType.orientation, TObject(180));
// And remember to flip the result points horizontally.
points := ReadResult.ResultPoints;
if (points <> nil) then
begin
points[0] := TResultPointHelpers.CreateResultPoint
(width - points[0].X - 1, points[0].Y);
points[1] := TResultPointHelpers.CreateResultPoint
(width - points[1].X - 1, points[1].Y);
end;
end;
Exit(ReadResult);
end; // loop
end;
Result := nil;
end;
class function TOneDReader.patternMatchVariance(counters,
pattern: TArray<Integer>; maxIndividualVariance: Integer): Integer;
var
scaledPattern, variance, counter, totalVariance, X, unitBarWidth, i,
patternLength, numCounters, total: Integer;
begin
Result := High(Integer);
numCounters := Length(counters);
total := 0;
patternLength := 0;
for i := 0 to numCounters - 1 do
begin
total := total + counters[i];
patternLength := patternLength + pattern[i];
end;
if (total < patternLength) then
// If we don't even have one pixel per unit of bar width, assume this is too small
// to reliably match, so fail:
Exit;
// We're going to fake floating-point math in integers. We just need to use more bits.
// Scale up patternLength so that intermediate values below like scaledCounter will have
// more "significant digits"
unitBarWidth := (total shl INTEGER_MATH_SHIFT) div patternLength;
maxIndividualVariance :=
TMathUtils.Asr((maxIndividualVariance * unitBarWidth), INTEGER_MATH_SHIFT);
totalVariance := 0;
for X := 0 to numCounters - 1 do
begin
counter := counters[X] shl INTEGER_MATH_SHIFT;
scaledPattern := pattern[X] * unitBarWidth;
if (counter > scaledPattern) then
variance := counter - scaledPattern
else
variance := scaledPattern - counter;
if (variance > maxIndividualVariance) then
Exit;
totalVariance := totalVariance + variance;
end;
Result := totalVariance div total;
end;
class function TOneDReader.recordPattern(row: IBitArray; start: Integer;
counters: TArray<Integer>): Boolean;
begin
Result := recordPattern(row, start, counters, Length(counters));
end;
class function TOneDReader.recordPattern(row: IBitArray; start: Integer;
counters: TArray<Integer>; numCounters: Integer): Boolean;
var
i, counterPosition, idx, ending: Integer;
isWhite: Boolean;
begin
for idx := 0 to numCounters - 1 do
begin
counters[idx] := 0;
end;
ending := row.Size;
if (start >= ending) then
begin
Result := false;
Exit;
end;
isWhite := not row[start];
counterPosition := 0;
i := start;
while (i < ending) do
begin
if (row[i] xor isWhite) then
begin // that is, exactly one is true
inc(counters[counterPosition]);
end
else
begin
inc(counterPosition);
if (counterPosition = numCounters) then
begin
break;
end
else
begin
counters[counterPosition] := 1;
isWhite := not isWhite;
end;
end;
inc(i);
end;
// If we read fully the last section of pixels and filled up our counters -- or filled
// the last counter but ran off the side of the image, OK. Otherwise, a problem.
Result := ((counterPosition = numCounters) or
((counterPosition = (numCounters - 1)) and (i = ending)));
end;
class function TOneDReader.RecordPatternInReverse(row: IBitArray;
start: Integer; counters: TArray<Integer>): Boolean;
var
numTransitionsLeft: Integer;
last: Boolean;
begin
// This could be more efficient I guess
numTransitionsLeft := Length(counters);
last := row[start];
while ((start > 0) and (numTransitionsLeft >= 0)) do
begin
dec(start);
if (row[start] <> last) then
begin
dec(numTransitionsLeft);
last := not last;
end;
end;
if (numTransitionsLeft >= 0) then
begin
Result := false;
Exit;
end;
Result := recordPattern(row, start + 1, counters);
end;
procedure TOneDReader.reset;
begin
// do nothing
end;
initialization
TOneDReader.InitializeClass();
end.
@@ -0,0 +1,140 @@
unit ZXing.OneD.UPCAReader;
{
* Copyright 2008 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Original Authors: Sean Owen
* Delphi Implementation by E. Spelt
}
interface
uses
System.SysUtils,
System.Generics.Collections,
Math,
ZXing.OneD.OneDReader,
ZXing.Common.BitArray,
ZXing.BinaryBitmap,
ZXing.ReadResult,
ZXing.DecodeHintType,
ZXing.ResultPoint,
ZXing.BarcodeFormat,
ZXing.Helpers,
ZXing.OneD.EAN13Reader,
ZXing.OneD.UPCEANReader;
type
TUPCAReader = class(TUPCEANReader)
private
class var EAN13Reader: TUPCEANReader;
class function maybeReturnResult(pResult: TReadResult): TReadResult; static;
class procedure DoInitialize();
class procedure DoFinalize();
protected
public
class function DecodeMiddle(const row: IBitArray;
const startRange: TArray<Integer>; const resultString: TStringBuilder)
: Integer; override;
function decode(const image: TBinaryBitmap;
hints: TDictionary<TDecodeHintType, TObject>): TReadResult; override;
function decodeRow(const rowNumber: Integer; const row: IBitArray;
const hints: TDictionary<TDecodeHintType, TObject>): TReadResult;
overload; override;
function decodeRow(const rowNumber: Integer; const row: IBitArray;
const startGuardRange: TArray<Integer>;
const hints: TDictionary<TDecodeHintType, TObject>): TReadResult;
reintroduce; overload;
function BarcodeFormat: TBarcodeFormat; override;
end;
implementation
{ TUPCAReader }
class procedure TUPCAReader.DoFinalize;
begin
EAN13Reader.Free;
end;
class procedure TUPCAReader.DoInitialize;
begin
EAN13Reader := TEAN13Reader.Create();
end;
function TUPCAReader.decode(const image: TBinaryBitmap;
hints: TDictionary<TDecodeHintType, TObject>): TReadResult;
begin
result := TUPCAReader.maybeReturnResult(self.EAN13Reader.decode(image, hints))
end;
class function TUPCAReader.DecodeMiddle(const row: IBitArray;
const startRange: TArray<Integer>;
const resultString: TStringBuilder): Integer;
begin
result := self.EAN13Reader.DecodeMiddle(row, startRange, resultString)
end;
function TUPCAReader.decodeRow(const rowNumber: Integer; const row: IBitArray;
const hints: TDictionary<TDecodeHintType, TObject>): TReadResult;
begin
result := TUPCAReader.maybeReturnResult(self.EAN13Reader.decodeRow(rowNumber,
row, hints))
end;
function TUPCAReader.decodeRow(const rowNumber: Integer; const row: IBitArray;
const startGuardRange: TArray<Integer>;
const hints: TDictionary<TDecodeHintType, TObject>): TReadResult;
begin
result := TUPCAReader.maybeReturnResult
(self.EAN13Reader.doDecodeRow(rowNumber, row, startGuardRange, hints))
end;
function TUPCAReader.BarcodeFormat: TBarcodeFormat;
begin
result := TBarcodeFormat.UPC_A;
end;
class function TUPCAReader.maybeReturnResult(pResult: TReadResult): TReadResult;
begin
if not Assigned(pResult) then
Exit(nil);
{$ZEROBASEDSTRINGS ON}
if (copy(pResult.text, 0, 1) = '0') then
begin
pResult.text := copy(pResult.text, 2, length(pResult.text));
pResult.BarcodeFormat := TBarcodeFormat.UPC_A;
end;
{$ZEROBASEDSTRINGS OFF}
result := pResult;
end;
initialization
TUPCAReader.DoInitialize;
finalization
TUPCAReader.DoFinalize;
end.
@@ -0,0 +1,194 @@
{
* Copyright 2008 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Delphi Implementation by K. Gossens
}
unit ZXing.OneD.UPCEANExtension2Support;
interface
uses
System.SysUtils,
System.Generics.Collections,
System.Math,
ZXing.Reader,
ZXing.BarcodeFormat,
ZXing.BinaryBitmap,
ZXing.ReadResult,
ZXing.DecodeHintType,
ZXing.ResultMetadataType,
ZXing.ResultPoint,
ZXing.Common.BitArray;
type
/// <summary>
/// @see UPCEANExtension5Support
/// </summary>
TUPCEANExtension2Support = class sealed
private
class var
decodeMiddleCounters : TArray<Integer>;
decodeRowStringBuffer : TStringBuilder;
class procedure InitializeClass; static;
class procedure FinalizeClass; static;
class function decodeMiddle(const row: IBitArray;
const startRange: TArray<Integer>;
const resultString: TStringBuilder): Integer;
/// <summary>
/// Parses the extension string.
/// </summary>
/// <param name="raw">raw content of extension</param>
/// <returns>formatted interpretation of raw content as a {@link TMap} mapping
class function parseExtensionString(const raw: String): TResultMetadata; static;
public
class function decodeRow(const rowNumber: Integer; const row: IBitArray;
const extensionStartRange: TArray<Integer>): TReadResult;
end;
implementation
uses
ZXing.OneD.UPCEANReader;
{ TUPCEANExtension2Support }
class procedure TUPCEANExtension2Support.InitializeClass;
begin
decodeMiddleCounters := TArray<Integer>.Create(0, 0, 0, 0);
decodeRowStringBuffer := TStringBuilder.Create;
end;
class procedure TUPCEANExtension2Support.FinalizeClass;
begin
decodeMiddleCounters := nil;
decodeRowStringBuffer.Free;
end;
class function TUPCEANExtension2Support.decodeRow(const rowNumber: Integer;
const row: IBitArray; const extensionStartRange: TArray<Integer>): TReadResult;
var
res : TStringBuilder;
ending : Integer;
resultString : String;
extensionResult : TReadResult;
extensionData : TResultMetadata;
resultPoints : TArray<IResultPoint>;
begin
Result := nil;
res := decodeRowStringBuffer;
res.Length := 0;
ending := decodeMiddle(row, extensionStartRange, res);
if (ending < 0)
then
exit;
resultString := res.ToString;
extensionData := TUPCEANExtension2Support.parseExtensionString(resultString);
resultPoints := TArray<IResultPoint>.Create(
TResultPointHelpers.CreateResultPoint((extensionStartRange[0] + extensionStartRange[1]) div 2, rowNumber),
TResultPointHelpers.CreateResultPoint(ending, rowNumber));
extensionResult := TReadResult.Create(resultString, nil, resultPoints, TBarcodeFormat.UPC_EAN_EXTENSION);
if (extensionData <> nil)
then
begin
extensionResult.putAllMetadata(extensionData);
FreeAndNil(extensionData);
end;
Result := extensionResult;
end;
class function TUPCEANExtension2Support.decodeMiddle(const row: IBitArray;
const startRange: TArray<Integer>; const resultString: TStringBuilder): Integer;
var
bestMatch: Integer;
counter: Integer;
ending: Integer;
counters : TArray<Integer>;
rowOffset, x,
checkParity: Integer;
begin
Result := -1;
counters := decodeMiddleCounters;
counters[0] := 0;
counters[1] := 0;
counters[2] := 0;
counters[3] := 0;
ending := row.Size;
rowOffset := startRange[1];
checkParity := 0;
x := 0;
while ((x < 2) and (rowOffset < ending)) do
begin
if (not TUPCEANReader.decodeDigit(row, counters, rowOffset, TUPCEANReader.L_AND_G_PATTERNS, bestMatch))
then
exit;
resultString.Append(IntToStr(bestMatch mod 10));
for counter in counters do
Inc(rowOffset, counter);
if (bestMatch >= 10)
then
checkParity := checkParity or (1 shl (1 - x));
if (x <> 1) then
begin
// Read off separator if not last
rowOffset := row.getNextSet(rowOffset);
rowOffset := row.getNextUnset(rowOffset);
end;
Inc(x);
end;
if (resultString.Length <> 2)
then
exit;
if ((Integer.Parse(resultString.ToString) mod 4) <> checkParity)
then
exit;
Result := rowOffset;
end;
class function TUPCEANExtension2Support.parseExtensionString(const raw: String): TResultMetadata;
var
dictionary1: TResultMetadata;
begin
Result := nil;
if (Length(raw) <> 2)
then
exit;
dictionary1 := TResultMetadata.Create;
dictionary1.Add(ZXing.ResultMetadataType.ISSUE_NUMBER, TResultMetaData.CreateStringMetadata(raw));
Result := dictionary1;
end;
initialization
TUPCEANExtension2Support.InitializeClass;
finalization
TUPCEANExtension2Support.FinalizeClass;
end.
@@ -0,0 +1,311 @@
{
* Copyright 2008 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Delphi Implementation by K. Gossens
}
unit ZXing.OneD.UPCEANExtension5Support;
interface
uses
System.SysUtils,
System.Generics.Collections,
System.Math,
ZXing.Reader,
ZXing.BinaryBitmap,
ZXing.ReadResult,
ZXing.BarcodeFormat,
ZXing.DecodeHintType,
ZXing.ResultMetadataType,
ZXing.ResultPoint,
ZXing.Common.BitArray,
ZXing.Common.Detector.MathUtils;
type
(**
* @see TUPCEANExtension2Support
*)
TUPCEANExtension5Support = class sealed
private
class var
CHECK_DIGIT_ENCODINGS : TArray<Integer>;
decodeMiddleCounters : TArray<Integer>;
decodeRowStringBuffer : TStringBuilder;
class procedure InitializeClass; static;
class procedure FinalizeClass; static;
class function decodeMiddle(const row: IBitArray;
const startRange: TArray<Integer>;
const resultString: TStringBuilder): Integer;
class function extensionChecksum(const s: string): Integer; static;
class function determineCheckDigit(const lgPatternFound: Integer;
var checkDigit: Integer): Boolean; static;
/// <summary>
/// Parses the extension string.
/// </summary>
/// <param name="raw">raw content of extension</param>
/// <returns>formatted interpretation of raw content as a {@link TMap} mapping
/// one {@link TResultMetadataType} to appropriate value, or {@code nil} if not known</returns>
class function parseExtensionString(
const raw: string): TResultMetadata; static;
class function parseExtension5String(const raw: String): String; static;
public
class function decodeRow(const rowNumber: Integer; const row: IBitArray;
const extensionStartRange: TArray<Integer>): TReadResult;
end;
implementation
uses
ZXing.OneD.UPCEANReader;
{ TUPCEANExtension2Support }
class procedure TUPCEANExtension5Support.InitializeClass;
begin
CHECK_DIGIT_ENCODINGS := TArray<Integer>.Create($18, $14, $12, $11, $0C,
$06, $03, $0A, $09, $05);
decodeMiddleCounters := TArray<Integer>.Create(0, 0, 0, 0);
decodeRowStringBuffer := TStringBuilder.Create;
end;
class procedure TUPCEANExtension5Support.FinalizeClass;
begin
CHECK_DIGIT_ENCODINGS := nil;
decodeMiddleCounters := nil;
decodeRowStringBuffer.Free;
end;
class function TUPCEANExtension5Support.decodeRow(const rowNumber: Integer;
const row: IBitArray; const extensionStartRange: TArray<Integer>): TReadResult;
var
res : TStringBuilder;
ending : Integer;
resultString : String;
extensionData : TResultMetadata;
resultPoints : TArray<IResultPoint>;
extensionResult : TReadResult;
begin
Result := nil;
res := decodeRowStringBuffer;
res.Length := 0;
ending := decodeMiddle(row, extensionStartRange, res);
if (ending < 0)
then
exit;
resultString := res.ToString;
extensionData := parseExtensionString(resultString);
resultPoints := TArray<IResultPoint>.Create(
TResultPointHelpers.CreateResultPoint((extensionStartRange[0] + extensionStartRange[1]) div 2, rowNumber),
TResultPointHelpers.CreateResultPoint(ending, rowNumber));
extensionResult := TReadResult.Create(resultString, nil, resultPoints, TBarcodeFormat.UPC_EAN_EXTENSION);
if (extensionData <> nil)
then
begin
extensionResult.putAllMetadata(extensionData);
FreeAndNil(extensionData);
end;
Result := extensionResult;
end;
class function TUPCEANExtension5Support.decodeMiddle(const row: IBitArray;
const startRange: TArray<Integer>; const resultString: TStringBuilder): Integer;
var
bestMatch: Integer;
counter: Integer;
ending: Integer;
counters : TArray<Integer>;
rowOffset, x,
lgPatternFound,
checkDigit : Integer;
begin
Result := -1;
counters := decodeMiddleCounters;
counters[0] := 0;
counters[1] := 0;
counters[2] := 0;
counters[3] := 0;
ending := row.Size;
rowOffset := startRange[1];
lgPatternFound := 0;
x := 0;
while (((x < 5) and (rowOffset < ending))) do
begin
if (not TUPCEANReader.decodeDigit(row, counters, rowOffset, TUPCEANReader.L_AND_G_PATTERNS, bestMatch))
then
exit;
resultString.Append(IntToStr(bestMatch mod 10));
for counter in counters do
Inc(rowOffset, counter);
if (bestMatch >= 10)
then
lgPatternFound := lgPatternFound or (1 shl (4 - x));
if (x <> 4) then
begin
// Read off separator if not last
rowOffset := row.getNextSet(rowOffset);
rowOffset := row.getNextUnset(rowOffset)
end;
Inc(x);
end;
if (resultString.Length <> 5)
then
exit;
if (not determineCheckDigit(lgPatternFound, checkDigit))
then
exit;
if (extensionChecksum(resultString.ToString) <> checkDigit)
then
exit;
Result := rowOffset;
end;
class function TUPCEANExtension5Support.extensionChecksum(
const s: String): Integer;
var
len,
sum, i : Integer;
begin
len := Length(s);
sum := 0;
i := (len - 2);
while ((i >= 0)) do
begin
Inc(sum, StrToIntDef(s.Chars[i], 0));
Dec(i, 2);
end;
sum := (sum * 3);
i := (len - 1);
while ((i >= 0)) do
begin
Inc(sum, StrToIntDef(s.Chars[i], 0));
Dec(i, 2);
end;
sum := (sum * 3);
Result := (sum mod 10);
end;
class function TUPCEANExtension5Support.determineCheckDigit(
const lgPatternFound: Integer; var checkDigit: Integer): Boolean;
var
i: Integer;
begin
Result := false;
for i := 0 to Pred(10) do
begin
if (lgPatternFound = CHECK_DIGIT_ENCODINGS[i]) then
begin
Result := true;
checkDigit := i;
break;
end;
end;
end;
class function TUPCEANExtension5Support.parseExtensionString(
const raw: String): TResultMetadata;
var
value: String;
dictionary1: TResultMetadata;
begin
Result := nil;
if (Length(raw) <> 5)
then
exit;
value := TUPCEANExtension5Support.parseExtension5String(raw);
//
// if (Length(value) = 0)
// then
// Result := nil;
dictionary1 := TResultMetadata.Create();
dictionary1.Add(ZXing.ResultMetadataType.SUGGESTED_PRICE, TResultMetadata.CreateStringMetadata(value));
Result := dictionary1;
end;
class function TUPCEANExtension5Support.parseExtension5String(
const raw: String): String;
var
currency,
unitsString,
hundredthsString : string;
rawAmount,
hundredths : Integer;
begin
Result := '';
case raw[1] of
'0' : currency := '£';
'5' : currency := '$';
'9' : begin
// Reference: http://www.jollytech.com
if ('90000'.Equals(raw))
then
// No suggested retail price
exit;
if ('99991'.Equals(raw))
then
// Complementary
Result := '0.00';
if ('99990'.Equals(raw))
then
Result := 'Used';
// Otherwise... unknown currency?
currency := '';
end;
else currency := '';
end;
rawAmount := Integer.Parse(raw.Substring(1));
unitsString := ((rawAmount div 100)).ToString;
hundredths := (rawAmount mod 100);
if (hundredths < 10)
then
hundredthsString := '0' + hundredths.ToString
else
hundredthsString := hundredths.ToString;
Result := currency + unitsString + '.' + hundredthsString;
end;
initialization
TUPCEANExtension5Support.InitializeClass;
finalization
TUPCEANExtension5Support.FinalizeClass;
end.
@@ -0,0 +1,99 @@
{
* Copyright 2008 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Delphi Implementation by K. Gossens
}
unit ZXing.OneD.UPCEANExtensionSupport;
interface
uses
System.SysUtils,
System.Generics.Collections,
System.Math,
ZXing.OneD.UPCEANExtension2Support,
ZXing.OneD.UPCEANExtension5Support,
ZXing.Reader,
ZXing.BinaryBitmap,
ZXing.ReadResult,
ZXing.DecodeHintType,
ZXing.ResultMetadataType,
ZXing.ResultPoint,
ZXing.Common.BitArray,
ZXing.Common.Detector.MathUtils;
type
TUPCEANExtensionSupport = class sealed
private
class var
EXTENSION_START_PATTERN : TArray<Integer>;
twoSupport : TUPCEANExtension2Support;
fiveSupport : TUPCEANExtension5Support;
class procedure InitializeClass; static;
class procedure FinalizeClass; static;
public
function decodeRow(const rowNumber: Integer; const row: IBitArray;
const rowOffset: Integer): TReadResult;
end;
implementation
uses
ZXing.OneD.UPCEANReader;
{ TUPCEANExtensionSupport }
class procedure TUPCEANExtensionSupport.InitializeClass();
begin
EXTENSION_START_PATTERN := TArray<Integer>.Create(1, 1, 2);
twoSupport := TUPCEANExtension2Support.Create();
fiveSupport := TUPCEANExtension5Support.Create();
end;
class procedure TUPCEANExtensionSupport.FinalizeClass();
begin
EXTENSION_START_PATTERN := nil;
twoSupport.Free;
fiveSupport.Free;
end;
function TUPCEANExtensionSupport.decodeRow(const rowNumber: Integer;
const row: IBitArray; const rowOffset: Integer): TReadResult;
var
extensionStartRange: TArray<Integer>;
res : TReadResult;
begin
Result := nil;
extensionStartRange := TUPCEANReader.findGuardPattern(row, rowOffset,
false, EXTENSION_START_PATTERN);
if (extensionStartRange = nil)
then
exit;
res := fiveSupport.decodeRow(rowNumber, row, extensionStartRange);
if (res = nil)
then
res := twoSupport.decodeRow(rowNumber, row, extensionStartRange);
Result := res;
end;
initialization
TUPCEANExtensionSupport.InitializeClass;
finalization
TUPCEANExtensionSupport.FinalizeClass;
end.
@@ -0,0 +1,592 @@
{
* Copyright 2008 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Original Authors: dswitkin@google.com (Daniel Switkin), Sean Owen and
* alasdair@google.com (Alasdair Mackintosh)
* Delphi Implementation by K. Gossens
}
unit ZXing.OneD.UPCEANReader;
interface
uses
System.SysUtils,
System.Generics.Collections,
System.Math,
ZXing.OneD.OneDReader,
ZXing.Common.BitArray,
ZXing.OneD.UPCEANExtensionSupport,
ZXing.OneD.EANManufacturerOrgSupport,
ZXing.ResultMetadataType,
ZXing.ReadResult,
ZXing.DecodeHintType,
ZXing.ResultPoint,
ZXing.BarcodeFormat;
type
/// <summary>
/// <p>Encapsulates functionality and implementation that is common to UPC and EAN families
/// of one-dimensional barcodes.</p>
/// </summary>
TUPCEANReader = class abstract(TOneDReader)
private
decodeRowStringBuffer: TStringBuilder;
extensionReader: TUPCEANExtensionSupport;
eanManSupport: TEANManufacturerOrgSupport;
/// <summary>
/// </summary>
/// <param name="row">row of black/white values to search</param>
/// <param name="rowOffset">position to start search</param>
/// <param name="whiteFirst">if true, indicates that the pattern specifies white/black/white/...</param>
/// pixel counts, otherwise, it is interpreted as black/white/black/...
/// <param name="pattern">pattern of counts of number of black and white pixels that are being</param>
/// searched for as a pattern
/// <param name="counters">array of counters, as long as pattern, to re-use</param>
/// <returns>start/end horizontal offset of guard pattern, as an array of two ints</returns>
class function findGuardPattern(const row: IBitArray; rowOffset: Integer;
const whiteFirst: Boolean; const pattern: TArray<Integer>;
counters: TArray<Integer>): TArray<Integer>; overload;
/// <summary>
/// Computes the UPC/EAN checksum on a string of digits, and reports
/// whether the checksum is correct or not.
/// </summary>
/// <param name="s">string of digits to check</param>
/// <returns>true iff string of digits passes the UPC/EAN checksum algorithm</returns>
class function checkStandardUPCEANChecksum(const s: String)
: Boolean; static;
class procedure InitializeClass; static;
class procedure FinalizeClass; static;
protected
class var
// These two values are critical for determining how permissive the decoding will be.
// We've arrived at these values through a lot of trial and error. Setting them any higher
// lets false positives creep in quickly.
MAX_AVG_VARIANCE: Integer;
MAX_INDIVIDUAL_VARIANCE: Integer;
/// <summary>
/// Start/end guard pattern.
/// </summary>
START_END_PATTERN: TArray<Integer>;
/// <summary>
/// Pattern marking the middle of a UPC/EAN pattern, separating the two halves.
/// </summary>
MIDDLE_PATTERN: TArray<Integer>;
/// <summary>
/// "Odd", or "L" patterns used to encode UPC/EAN digits.
/// </summary>
L_PATTERNS: TArray<TArray<Integer>>;
/// <summary>
/// Decodes the end.
/// </summary>
/// <param name="row">The row.</param>
/// <param name="endStart">The end start.</param>
/// <returns></returns>
class function decodeEnd(const row: IBitArray; const endStart: Integer)
: TArray<Integer>; virtual;
/// <summary>
/// </summary>
/// <param name="s">string of digits to check</param>
/// <returns>see <see cref="checkStandardUPCEANChecksum(String)"/></returns>
class function checkChecksum(const s: String): Boolean; virtual;
public
class var
/// <summary>
/// As above but also including the "even", or "G" patterns used to encode UPC/EAN digits.
/// </summary>
L_AND_G_PATTERNS: TArray<TArray<Integer>>;
/// <summary>
/// Initializes a new instance of the <see cref="TUPCEANReader"/> class.
/// </summary>
constructor Create; virtual;
destructor Destroy; override;
/// <summary>
/// Subclasses override this to decode the portion of a barcode between the start
/// and end guard patterns.
/// </summary>
/// <param name="row">row of black/white values to search</param>
/// <param name="startRange">start/end offset of start guard pattern</param>
/// <param name="resultString"><see cref="StringBuilder" />to append decoded chars to</param>
/// <returns>horizontal offset of first pixel after the "middle" that was decoded or -1 if decoding could not complete successfully</returns>
class function DecodeMiddle(const row: IBitArray;
const startRange: TArray<Integer>; const resultString: TStringBuilder)
: Integer; virtual; abstract;
/// <summary>
/// Get the format of this decoder.
/// </summary>
/// <returns>The 1D format.</returns>
function BarcodeFormat: TBarcodeFormat; virtual; abstract;
class function findStartGuardPattern(const row: IBitArray)
: TArray<Integer>; static;
class function findGuardPattern(const row: IBitArray;
const rowOffset: Integer; const whiteFirst: Boolean;
const pattern: TArray<Integer>): TArray<Integer>; overload;
/// <summary>
/// Attempts to decode a single UPC/EAN-encoded digit.
/// </summary>
/// <param name="row">row of black/white values to decode</param>
/// <param name="counters">the counts of runs of observed black/white/black/... values</param>
/// <param name="rowOffset">horizontal offset to start decoding from</param>
/// <param name="patterns">the set of patterns to use to decode -- sometimes different encodings</param>
/// for the digits 0-9 are used, and this indicates the encodings for 0 to 9 that should
/// be used
/// <returns>horizontal offset of first pixel beyond the decoded digit</returns>
class function decodeDigit(const row: IBitArray;
const counters: TArray<Integer>; const rowOffset: Integer;
const patterns: TArray<TArray<Integer>>; var digit: Integer): Boolean;
/// <summary>
/// <p>Attempts to decode a one-dimensional barcode format given a single row of
/// an image.</p>
/// </summary>
/// <param name="rowNumber">row number from top of the row</param>
/// <param name="row">the black/white pixel data of the row</param>
/// <param name="hints">decode hints</param>
/// <returns>
/// <see cref="TReadResult"/>containing encoded string and start/end of barcode or null, if an error occurs or barcode cannot be found
/// </returns>
function decodeRow(const rowNumber: Integer; const row: IBitArray;
const hints: TDictionary<TDecodeHintType, TObject>): TReadResult;
overload; override;
/// <summary>
/// <p>Like decodeRow(int, BitArray, java.util.Map), but
/// allows caller to inform method about where the UPC/EAN start pattern is
/// found. This allows this to be computed once and reused across many implementations.</p>
/// </summary>
/// <param name="rowNumber">row index into the image</param>
/// <param name="row">encoding of the row of the barcode image</param>
/// <param name="startGuardRange">start/end column where the opening start pattern was found</param>
/// <param name="hints">optional hints that influence decoding</param>
/// <returns><see cref="TReadResult"/> encapsulating the result of decoding a barcode in the row</returns>
function DoDecodeRow(const rowNumber: Integer; const row: IBitArray;
const startGuardRange: TArray<Integer>;
const hints: TDictionary<TDecodeHintType, TObject>): TReadResult;
end;
implementation
{ TUPCEANReader }
constructor TUPCEANReader.Create;
begin
inherited;
decodeRowStringBuffer := TStringBuilder.Create(20);
extensionReader := TUPCEANExtensionSupport.Create;
eanManSupport := TEANManufacturerOrgSupport.Create;
end;
destructor TUPCEANReader.Destroy;
begin
eanManSupport.Free;
extensionReader.Free;
decodeRowStringBuffer.Free;
inherited;
end;
class procedure TUPCEANReader.InitializeClass;
var
i, j: Integer;
widths, reversedWidths: TArray<Integer>;
begin
MAX_AVG_VARIANCE :=
Trunc(TOneDReader.PATTERN_MATCH_RESULT_SCALE_FACTOR * 0.48);
MAX_INDIVIDUAL_VARIANCE :=
Trunc(TOneDReader.PATTERN_MATCH_RESULT_SCALE_FACTOR * 0.7);
START_END_PATTERN := TArray<Integer>.Create(1, 1, 1);
MIDDLE_PATTERN := TArray<Integer>.Create(1, 1, 1, 1, 1);
L_PATTERNS := TArray < TArray < Integer >>
.Create(TArray<Integer>.Create(3, 2, 1, 1), // 0
TArray<Integer>.Create(2, 2, 2, 1), // 1
TArray<Integer>.Create(2, 1, 2, 2), // 2
TArray<Integer>.Create(1, 4, 1, 1), // 3
TArray<Integer>.Create(1, 1, 3, 2), // 4
TArray<Integer>.Create(1, 2, 3, 1), // 5
TArray<Integer>.Create(1, 1, 1, 4), // 6
TArray<Integer>.Create(1, 3, 1, 2), // 7
TArray<Integer>.Create(1, 2, 1, 3), // 8
TArray<Integer>.Create(3, 1, 1, 2) // 9
);
L_AND_G_PATTERNS := L_PATTERNS;
SetLength(L_AND_G_PATTERNS, 20);
// Move(L_PATTERNS[0], L_AND_G_PATTERNS[0], 10);
for i := 10 to Pred(20) do
begin
widths := L_PATTERNS[(i - 10)];
reversedWidths := TArray<Integer>.Create();
SetLength(reversedWidths, Length(widths));
for j := 0 to Pred(Length(widths)) do
reversedWidths[j] := widths[((Length(widths) - j) - 1)];
L_AND_G_PATTERNS[i] := reversedWidths;
end;
end;
class procedure TUPCEANReader.FinalizeClass;
begin
START_END_PATTERN := nil;
MIDDLE_PATTERN := nil;
L_PATTERNS := nil;
L_AND_G_PATTERNS := nil;
end;
class function TUPCEANReader.checkChecksum(const s: String): Boolean;
begin
Result := checkStandardUPCEANChecksum(s);
end;
class function TUPCEANReader.checkStandardUPCEANChecksum
(const s: String): Boolean;
var
len, sum, i, digit, ZeroInt: Integer;
begin
{$ZEROBASEDSTRINGS ON}
Result := false;
len := Length(s);
if (len = 0) then
exit;
sum := 0;
ZeroInt := Ord('0');
i := (len - 2);
while ((i >= 0)) do
begin
digit := Ord(s[i]) - ZeroInt;
if ((digit < 0) or (digit > 9)) then
exit;
Inc(sum, digit);
Dec(i, 2);
end;
sum := (sum * 3);
i := (len - 1);
while ((i >= 0)) do
begin
digit := Ord(s[i]) - ZeroInt;
if ((digit < 0) or (digit > 9)) then
exit;
Inc(sum, digit);
Dec(i, 2);
end;
{$ZEROBASEDSTRINGS OFF}
Result := ((sum mod 10) = 0);
end;
class function TUPCEANReader.decodeEnd(const row: IBitArray;
const endStart: Integer): TArray<Integer>;
begin
Result := findGuardPattern(row, endStart, false, START_END_PATTERN);
end;
class function TUPCEANReader.findStartGuardPattern(const row: IBitArray)
: TArray<Integer>;
var
foundStart: Boolean;
startRange, counters: TArray<Integer>;
nextStart, start, quietStart, idx, l: Integer;
begin
Result := nil;
foundStart := false;
startRange := nil;
nextStart := 0;
counters := TArray<Integer>.Create();
l := Length(START_END_PATTERN);
SetLength(counters, l);
while (not foundStart) do
begin
for idx := 0 to l - 1 do
counters[idx] := 0;
startRange := findGuardPattern(row, nextStart, false, START_END_PATTERN,
counters);
if (startRange = nil) then
exit;
start := startRange[0];
nextStart := startRange[1];
// Make sure there is a quiet zone at least as big as the start pattern before the barcode.
// If this check would run off the left edge of the image, do not accept this barcode,
// as it is very likely to be a false positive.
quietStart := start - (nextStart - start);
if (quietStart >= 0) then
foundStart := row.isRange(quietStart, start, false);
end;
counters:=nil;
Result := startRange;
end;
class function TUPCEANReader.findGuardPattern(const row: IBitArray;
const rowOffset: Integer; const whiteFirst: Boolean;
const pattern: TArray<Integer>): TArray<Integer>;
var
counters: TArray<Integer>;
begin
counters := TArray<Integer>.Create();
SetLength(counters, Length(pattern));
Result := findGuardPattern(row, rowOffset, whiteFirst, pattern, counters);
counters:=nil;
end;
class function TUPCEANReader.findGuardPattern(const row: IBitArray;
rowOffset: Integer; const whiteFirst: Boolean; const pattern: TArray<Integer>;
counters: TArray<Integer>): TArray<Integer>;
var
patternLength, width, x: Integer;
isWhite: Boolean;
counterPosition, patternStart: Integer;
curCounter: TArray<Integer>;
begin
Result := nil;
patternLength := Length(pattern);
width := row.Size;
isWhite := whiteFirst;
if whiteFirst then
rowOffset := row.getNextUnset(rowOffset)
else
rowOffset := row.getNextSet(rowOffset);
counterPosition := 0;
patternStart := rowOffset;
for x := rowOffset to Pred(width) do
begin
if (row[x] xor isWhite) then
Inc(counters[counterPosition])
else
begin
if (counterPosition = (patternLength - 1)) then
begin
if (patternMatchVariance(counters, pattern, MAX_INDIVIDUAL_VARIANCE) <
MAX_AVG_VARIANCE) then
begin
Result := TArray<Integer>.Create(patternStart, x);
break;
end;
Inc(patternStart, (counters[0] + counters[1]));
curCounter := TArray<Integer>.Create();
SetLength(curCounter, Length(counters));
TArray.Copy<Integer>(counters, curCounter, 2, 0, (patternLength - 2));
{ curCounter[patternLength - 2] := 0;
curCounter[patternLength - 1] := 0; }
counters := curCounter;
Dec(counterPosition);
end
else
Inc(counterPosition);
counters[counterPosition] := 1;
isWhite := not isWhite;
end;
end;
end;
class function TUPCEANReader.decodeDigit(const row: IBitArray;
const counters: TArray<Integer>; const rowOffset: Integer;
const patterns: TArray<TArray<Integer>>; var digit: Integer): Boolean;
var
bestVariance, variance, i, max: Integer;
pattern: TArray<Integer>;
begin
Result := false;
digit := -1;
if (not TOneDReader.recordPattern(row, rowOffset, counters)) then
exit;
bestVariance := TUPCEANReader.MAX_AVG_VARIANCE; // worst variance we'll accept
max := Length(patterns);
for i := 0 to Pred(max) do
begin
pattern := patterns[i];
variance := TOneDReader.patternMatchVariance(counters, pattern,
TUPCEANReader.MAX_INDIVIDUAL_VARIANCE);
if (variance < bestVariance) then
begin
bestVariance := variance;
digit := i;
end;
end;
Result := (digit >= 0);
end;
function TUPCEANReader.decodeRow(const rowNumber: Integer; const row: IBitArray;
const hints: TDictionary<TDecodeHintType, TObject>): TReadResult;
var
startRange: TArray<Integer>;
begin
startRange := findStartGuardPattern(row);
if startRange = nil then
exit(nil);
try
Result := DoDecodeRow(rowNumber, row, startRange, hints);
except
result := nil;
end;
end;
function TUPCEANReader.DoDecodeRow(const rowNumber: Integer;
const row: IBitArray;
const startGuardRange: TArray<Integer>;
const hints: TDictionary<TDecodeHintType, TObject>): TReadResult;
var
len: Integer;
res: TStringBuilder;
resultString: String;
endStart, ending, quietEnd: Integer;
endRange: TArray<Integer>;
resultPoints: TArray<IResultPoint>;
left, right: Single;
resultPointCallback: TResultPointCallback;
obj: TObject;
resPoint: IResultPoint;
decodeResult, extensionResult: TReadResult;
format: TBarcodeFormat;
allowedExtensions: TArray<Integer>;
valid: Boolean;
extensionLength: Integer;
countryID: String;
begin
Result := nil;
resultPointCallback := nil;
if ((hints <> nil) and
(hints.ContainsKey(TDecodeHintType.NEED_RESULT_POINT_CALLBACK))) then
begin
obj := hints[TDecodeHintType.NEED_RESULT_POINT_CALLBACK];
if (obj is TResultPointEventObject) then
resultPointCallback := TResultPointEventObject(obj).Event;
end;
res := decodeRowStringBuffer;
res.Length := 0;
endStart := DecodeMiddle(row, startGuardRange, res);
if (endStart < 0) then
exit;
if Assigned(resultPointCallback) then
begin
resPoint := TResultPointHelpers.CreateResultPoint(endStart, rowNumber);
resultPointCallback(resPoint);
end;
endRange := decodeEnd(row, endStart);
if (endRange = nil) then
exit;
if Assigned(resultPointCallback) then
begin
resPoint := TResultPointHelpers.CreateResultPoint
((endRange[0] + endRange[1]) div 2, rowNumber);
resultPointCallback(resPoint);
end;
ending := endRange[1];
quietEnd := (ending + (ending - endRange[0]));
if ((quietEnd >= row.Size) or not row.isRange(ending, quietEnd, false)) then
exit;
resultString := res.ToString;
if (Length(resultString) < 8) then
exit;
if (not checkChecksum(resultString)) then
exit;
left := ((startGuardRange[1] + startGuardRange[0]) div 2);
right := ((endRange[1] + endRange[0]) div 2);
format := BarcodeFormat;
resultPoints := TArray<IResultPoint>.Create
(TResultPointHelpers.CreateResultPoint(left, rowNumber),
TResultPointHelpers.CreateResultPoint(right, rowNumber));
decodeResult := TReadResult.Create(resultString, nil, resultPoints, format);
extensionResult := extensionReader.decodeRow(rowNumber, row, endRange[1]);
if (extensionResult <> nil) then
begin
decodeResult.putMetadata(TResultMetadataType.UPC_EAN_EXTENSION,
TResultMetaData.CreateStringMetadata(extensionResult.Text));
decodeResult.putAllMetadata(extensionResult.ResultMetadata);
decodeResult.addResultPoints(extensionResult.resultPoints);
extensionLength := Length(extensionResult.Text);
extensionResult.Free;
if (hints <> nil) and
(hints.ContainsKey(TDecodeHintType.ALLOWED_EAN_EXTENSIONS)) then
allowedExtensions := TArray<Integer>
(hints[TDecodeHintType.ALLOWED_EAN_EXTENSIONS])
else
allowedExtensions := nil;
if (allowedExtensions <> nil) then
begin
valid := false;
for len in allowedExtensions do
begin
if (extensionLength = len) then
begin
valid := true;
break;
end;
end;
if (not valid) then
exit;
end
end;
case format of
TBarcodeFormat.EAN_13, TBarcodeFormat.UPC_A:
begin
countryID := eanManSupport.lookupCountryIdentifier(resultString);
if (countryID <> '') then
decodeResult.putMetadata(TResultMetadataType.POSSIBLE_COUNTRY,
TResultMetaData.CreateStringMetadata(countryID));
end;
end;
Result := decodeResult;
end;
initialization
TUPCEANReader.InitializeClass;
finalization
TUPCEANReader.FinalizeClass;
end.
@@ -0,0 +1,235 @@
unit ZXing.OneD.UPCEReader;
{
* Copyright 2008 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Original Authors: Sean Owen
* Delphi Implementation by E. Spelt
}
interface
uses
System.SysUtils,
System.Generics.Collections,
Math,
ZXing.OneD.OneDReader,
ZXing.Common.BitArray,
ZXing.BinaryBitmap,
ZXing.ReadResult,
ZXing.DecodeHintType,
ZXing.ResultPoint,
ZXing.BarcodeFormat,
ZXing.Helpers,
ZXing.OneD.EAN13Reader,
ZXing.OneD.UPCEANReader;
type
T2DIntArray = TArray<TArray<Integer>>;
TUPCEReader = class(TUPCEANReader)
private
class var decodeMiddleCounters: TArray<Integer>;
class var MIDDLE_END_PATTERN: TArray<Integer>;
class var NUMSYS_AND_CHECK_DIGIT_PATTERNS: T2DIntArray;
class procedure DoInitialize();
class procedure DoFinalize();
class function determineNumSysAndCheckDigit(resultString: TStringBuilder;
lgPatternFound: Integer): boolean; static;
protected
class function checkChecksum(const s: string): boolean; override;
class function decodeEnd(const row: IBitArray; const endStart: Integer)
: TArray<Integer>; override;
public
class function DecodeMiddle(const row: IBitArray;
const startRange: TArray<Integer>; const res: TStringBuilder)
: Integer; override;
public
class function convertUPCEtoUPCA(upce: string): string; static;
function BarcodeFormat: TBarcodeFormat; override;
end;
implementation
{ TUPCEReader }
class function TUPCEReader.determineNumSysAndCheckDigit
(resultString: TStringBuilder; lgPatternFound: Integer): boolean;
var
numSys, d: Integer;
begin
numSys := 0;
while ((numSys <= 1)) do
begin
d := 0;
while ((d < 10)) do
begin
if (lgPatternFound = TUPCEReader.NUMSYS_AND_CHECK_DIGIT_PATTERNS
[numSys][d]) then
begin
resultString.Insert(0, Char($30 + numSys) );
resultString.Append(char($30 + d));
begin
Result := true;
exit
end
end;
inc(d)
end;
inc(numSys)
end;
Result := false;
end;
class function TUPCEReader.checkChecksum(const s: string): boolean;
begin
Result := inherited checkChecksum(TUPCEReader.convertUPCEtoUPCA(s))
end;
class function TUPCEReader.convertUPCEtoUPCA(upce: string): string;
var
upceChars: string;
res: TStringBuilder;
lastChar: char;
begin
upceChars := upce.Substring(1, 6);
res := TStringBuilder.Create(12);
res.Append(upce.Chars[0]);
lastChar := upceChars.Chars[5];
case lastChar of
'0', '1', '2':
begin
res.Append(upceChars, 0, 2);
res.Append(lastChar);
res.Append('0000');
res.Append(upceChars, 2, 3);
end;
'3':
begin
res.Append(upceChars, 0, 3);
res.Append('00000');
res.Append(upceChars, 3, 2);
end;
'4':
begin
res.Append(upceChars, 0, 4);
res.Append('00000');
res.Append(upceChars.Chars[4]);
end;
else
begin
res.Append(upceChars, 0, 5);
res.Append('0000');
res.Append(lastChar);
end;
end;
res.Append(upce.Chars[7]);
Result := res.ToString;
res.Free;
end;
class function TUPCEReader.decodeEnd(const row: IBitArray;
const endStart: Integer): TArray<Integer>;
begin
Result := TUPCEANReader.findGuardPattern(row, endStart, true,
TUPCEReader.MIDDLE_END_PATTERN);
end;
class function TUPCEReader.DecodeMiddle(const row: IBitArray;
const startRange: TArray<Integer>; const res: TStringBuilder): Integer;
var
bestMatch: Integer;
counter, ending, lgPatternFound, rowOffset, x: Integer;
counters: TArray<Integer>;
begin
counters := self.decodeMiddleCounters;
counters[0] := 0;
counters[1] := 0;
counters[2] := 0;
counters[3] := 0;
ending := row.Size;
rowOffset := startRange[1];
lgPatternFound := 0;
x := 0;
while ((x < 6) and (rowOffset < ending)) do
begin
if (not TUPCEANReader.decodeDigit(row, counters, rowOffset,
TUPCEANReader.L_AND_G_PATTERNS, bestMatch)) then
begin
exit(-1);
end;
res.Append(Char(ord('0') + bestMatch mod 10));
for counter in counters do
begin
inc(rowOffset, counter)
end;
if (bestMatch >= 10) then
lgPatternFound := lgPatternFound or (1 shl (5 - x));
inc(x)
end;
if (not TUPCEReader.determineNumSysAndCheckDigit(res, lgPatternFound)) then
begin
exit(-1);
end;
Result := rowOffset;
end;
function TUPCEReader.BarcodeFormat: TBarcodeFormat;
begin
Result := TBarcodeFormat.UPC_E;
end;
class procedure TUPCEReader.DoInitialize;
begin
MIDDLE_END_PATTERN := TArray<Integer>.Create(1, 1, 1, 1, 1, 1);
NUMSYS_AND_CHECK_DIGIT_PATTERNS :=
T2DIntArray.Create(TArray<Integer>.Create($38, $34, 50, $31, $2C, $26, $23,
$2A, $29, $25), TArray<Integer>.Create(7, 11, 13, 14, $13, $19, $1C, $15,
$16, $1A));
decodeMiddleCounters := TArray<Integer>.Create(0,0,0,0);
end;
class procedure TUPCEReader.DoFinalize;
begin
MIDDLE_END_PATTERN := nil;
NUMSYS_AND_CHECK_DIGIT_PATTERNS := nil;
decodeMiddleCounters := nil;
end;
initialization
TUPCEReader.DoInitialize;
finalization
TUPCEReader.DoFinalize;
end.
@@ -0,0 +1,564 @@
{
* Copyright 2008 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Original Author: bbrown@google.com (Brian Brown)
* Delphi Implementation by K. Gossens
}
unit ZXing.Datamatrix.Internal.BitMatrixParser;
interface
uses
System.SysUtils,
System.Generics.Collections,
ZXing.DecodeHintType,
ZXing.Common.BitMatrix,
ZXing.QrCode.Internal.FormatInformation,
ZXing.Common.Detector.MathUtils,
ZXing.Datamatrix.Internal.Version;
type
TBitMatrixParser = class sealed
private
mappingBitMatrix: TBitMatrix;
readMappingMatrix: TBitMatrix;
Fversion: TVersion;
/// <summary>
/// <p>Reads a bit of the mapping matrix accounting for boundary wrapping.</p>
///
/// <param name="row">Row to read in the mapping matrix</param>
/// <param name="column">Column to read in the mapping matrix</param>
/// <param name="numRows">Number of rows in the mapping matrix</param>
/// <param name="numColumns">Number of columns in the mapping matrix</param>
/// <returns>value of the given bit in the mapping matrix</returns>
/// </summary>
function readModule(row, column, numRows, numColumns: Integer): Boolean;
/// <summary>
/// <p>Reads the 8 bits of the standard Utah-shaped pattern.</p>
///
/// <p>See ISO 16022:2006, 5.8.1 Figure 6</p>
///
/// <param name="row">Current row in the mapping matrix, anchored at the 8th bit (LSB) of the pattern</param>
/// <param name="column">Current column in the mapping matrix, anchored at the 8th bit (LSB) of the pattern</param>
/// <param name="numRows">Number of rows in the mapping matrix</param>
/// <param name="numColumns">Number of columns in the mapping matrix</param>
/// <returns>byte from the utah shape</returns>
/// </summary>
function readUtah(row, column, numRows, numColumns: Integer): Integer;
/// <summary>
/// <p>Reads the 8 bits of the special corner condition 1.</p>
///
/// <p>See ISO 16022:2006, Figure F.3</p>
///
/// <param name="numRows">Number of rows in the mapping matrix</param>
/// <param name="numColumns">Number of columns in the mapping matrix</param>
/// <returns>byte from the Corner condition 1</returns>
/// </summary>
function readCorner1(numRows, numColumns: Integer): Integer;
/// <summary>
/// <p>Reads the 8 bits of the special corner condition 2.</p>
///
/// <p>See ISO 16022:2006, Figure F.4</p>
///
/// <param name="numRows">Number of rows in the mapping matrix</param>
/// <param name="numColumns">Number of columns in the mapping matrix</param>
/// <returns>byte from the Corner condition 2</returns>
/// </summary>
function readCorner2(numRows, numColumns: Integer): Integer;
/// <summary>
/// <p>Reads the 8 bits of the special corner condition 3.</p>
///
/// <p>See ISO 16022:2006, Figure F.5</p>
///
/// <param name="numRows">Number of rows in the mapping matrix</param>
/// <param name="numColumns">Number of columns in the mapping matrix</param>
/// <returns>byte from the Corner condition 3</returns>
/// </summary>
function readCorner3(numRows, numColumns: Integer): Integer;
/// <summary>
/// <p>Reads the 8 bits of the special corner condition 4.</p>
///
/// <p>See ISO 16022:2006, Figure F.6</p>
///
/// <param name="numRows">Number of rows in the mapping matrix</param>
/// <param name="numColumns">Number of columns in the mapping matrix</param>
/// <returns>byte from the Corner condition 4</returns>
/// </summary>
function readCorner4(numRows, numColumns: Integer): Integer;
/// <summary>
/// <p>Creates the version object based on the dimension of the original bit matrix from
/// the datamatrix code.</p>
///
/// <p>See ISO 16022:2006 Table 7 - ECC 200 symbol attributes</p>
///
/// <param name="bitMatrix">Original <see cref="BitMatrix" />including alignment patterns</param>
/// <returns><see cref="Version" />encapsulating the Data Matrix Code's "version"</returns>
/// <exception cref="FormatException">if the dimensions of the mapping matrix are not valid</exception>
/// Data Matrix dimensions.
/// </summary>
function readVersion(BitMatrix: TBitMatrix): TVersion;
public
/// <param name="bitMatrix">{@link TBitMatrix} to parse</param>
/// <throws>ReaderException if dimension is not >= 21 and 1 mod 4</throws>
constructor Create(const BitMatrix: TBitMatrix);
/// <summary>
/// <p>Extracts the data region from a <see cref="BitMatrix" />that contains
/// alignment patterns.</p>
///
/// <param name="bitMatrix">Original <see cref="BitMatrix" />with alignment patterns</param>
/// <returns>BitMatrix that has the alignment patterns removed</returns>
/// </summary>
function extractDataRegion(BitMatrix: TBitMatrix): TBitMatrix;
/// <summary>
/// <p>Reads the bits in the <see cref="BitMatrix" />representing the mapping matrix (No alignment patterns)
/// in the correct order in order to reconstitute the codewords bytes contained within the
/// Data Matrix Code.</p>
///
/// <returns>bytes encoded within the Data Matrix Code</returns>
/// <exception cref="FormatException">if the exact number of bytes expected is not read</exception>
/// </summary>
function readCodewords: TArray<Byte>;
destructor Destroy; override;
property Version: TVersion read Fversion;
end;
implementation
{ TBitMatrixParser }
constructor TBitMatrixParser.Create(const BitMatrix: TBitMatrix);
var
dimension: Integer;
begin
dimension := BitMatrix.Height;
if (((dimension >= 8) and (dimension <= 144)) and ((dimension and $01) = 0))
then
begin
self.Fversion := readVersion(BitMatrix);
if (self.Version <> nil) then
begin
self.mappingBitMatrix := extractDataRegion(BitMatrix);
self.readMappingMatrix := TBitMatrix.Create(self.mappingBitMatrix.Width,
self.mappingBitMatrix.Height)
end;
end;
end;
destructor TBitMatrixParser.Destroy;
begin
self.mappingBitMatrix.Free;
self.readMappingMatrix.Free;
inherited;
end;
function TBitMatrixParser.readVersion(BitMatrix: TBitMatrix): TVersion;
begin
Result := TVersion.getVersionForDimensions(BitMatrix.Height, BitMatrix.Width);
end;
function TBitMatrixParser.readCodewords: TArray<Byte>;
var
resultOffset, row, column, numRows, numColumns: Integer;
corner1Read, corner2Read, corner3Read, corner4Read: Boolean;
begin
Result := TArray<Byte>.Create();
SetLength(Result, Version.TotalCodewords);
resultOffset := 0;
row := 4;
column := 0;
numRows := self.mappingBitMatrix.Height;
numColumns := self.mappingBitMatrix.Width;
corner1Read := false;
corner2Read := false;
corner3Read := false;
corner4Read := false;
// Read all of the codewords
while ((row < numRows) or (column < numColumns)) do
begin
// Check the four corner cases
if ((row = numRows) and (column = 0) and (not corner1Read)) then
begin
Result[resultOffset] := Byte(readCorner1(numRows, numColumns));
Inc(resultOffset);
Dec(row, 2);
Inc(column, 2);
corner1Read := true;
end
else
begin
if ((row = (numRows - 2)) and (column = 0) and ((numColumns and $03) <> 0)
and (not corner2Read)) then
begin
Result[resultOffset] := Byte(readCorner2(numRows, numColumns));
Inc(resultOffset);
Dec(row, 2);
Inc(column, 2);
corner2Read := true;
end
else
begin
if ((row = (numRows + 4)) and (column = 2) and
((numColumns and $07) = 0) and (not corner3Read)) then
begin
Result[resultOffset] := Byte(readCorner3(numRows, numColumns));
Inc(resultOffset);
Dec(row, 2);
Inc(column, 2);
corner3Read := true;
end
else
begin
if ((row = (numRows - 2)) and (column = 0) and
((numColumns and $07) = 4) and (not corner4Read)) then
begin
Result[resultOffset] := Byte(readCorner4(numRows, numColumns));
Inc(resultOffset);
Dec(row, 2);
Inc(column, 2);
corner4Read := true;
end
else
begin
// Sweep upward diagonally to the right
while ((row >= 0) and (column < numColumns)) do
begin
if ((row < numRows) and (column >= 0) and
(not readMappingMatrix[column, row])) then
begin
Result[resultOffset] :=
Byte(readUtah(row, column, numRows, numColumns));
Inc(resultOffset);
end;
Dec(row, 2);
Inc(column, 2)
end;
Inc(row);
Inc(column, 3);
// Sweep downward diagonally to the left
while ((row < numRows) and (column >= 0)) do
begin
if ((row >= 0) and (column < numColumns) and
(not readMappingMatrix[column, row])) then
begin
Result[resultOffset] :=
Byte(readUtah(row, column, numRows, numColumns));
Inc(resultOffset);
end;
Inc(row, 2);
Dec(column, 2)
end;
Inc(row, 3);
Inc(column)
end;
end;
end;
end;
end;
if (resultOffset <> Version.TotalCodewords) then
Result := nil;
end;
function TBitMatrixParser.readModule(row, column, numRows,
numColumns: Integer): Boolean;
begin
// Adjust the row and column indices based on boundary wrapping
if (row < 0) then
begin
Inc(row, numRows);
Inc(column, (4 - ((numRows + 4) and $07)))
end;
if (column < 0) then
begin
Inc(column, numColumns);
Inc(row, (4 - ((numColumns + 4) and $07)))
end;
readMappingMatrix[column, row] := true;
Result := mappingBitMatrix[column, row];
end;
function TBitMatrixParser.readUtah(row, column, numRows,
numColumns: Integer): Integer;
var
currentByte: Byte;
begin
currentByte := 0;
if (readModule((row - 2), (column - 2), numRows, numColumns)) then
currentByte := (currentByte or 1);
currentByte := (currentByte shl 1);
if (readModule((row - 2), (column - 1), numRows, numColumns)) then
currentByte := (currentByte or 1);
currentByte := (currentByte shl 1);
if (readModule((row - 1), (column - 2), numRows, numColumns)) then
currentByte := (currentByte or 1);
currentByte := (currentByte shl 1);
if (readModule((row - 1), (column - 1), numRows, numColumns)) then
currentByte := (currentByte or 1);
currentByte := (currentByte shl 1);
if (readModule((row - 1), column, numRows, numColumns)) then
currentByte := (currentByte or 1);
currentByte := (currentByte shl 1);
if (readModule(row, (column - 2), numRows, numColumns)) then
currentByte := (currentByte or 1);
currentByte := (currentByte shl 1);
if (readModule(row, (column - 1), numRows, numColumns)) then
currentByte := (currentByte or 1);
currentByte := (currentByte shl 1);
if (readModule(row, column, numRows, numColumns)) then
currentByte := (currentByte or 1);
Result := currentByte;
end;
function TBitMatrixParser.readCorner1(numRows, numColumns: Integer): Integer;
var
currentByte: Byte;
begin
currentByte := 0;
if (readModule((numRows - 1), 0, numRows, numColumns)) then
currentByte := (currentByte or 1);
currentByte := (currentByte shl 1);
if (readModule((numRows - 1), 1, numRows, numColumns)) then
currentByte := (currentByte or 1);
currentByte := (currentByte shl 1);
if (readModule((numRows - 1), 2, numRows, numColumns)) then
currentByte := (currentByte or 1);
currentByte := (currentByte shl 1);
if (readModule(0, (numColumns - 2), numRows, numColumns)) then
currentByte := (currentByte or 1);
currentByte := (currentByte shl 1);
if (readModule(0, (numColumns - 1), numRows, numColumns)) then
currentByte := (currentByte or 1);
currentByte := (currentByte shl 1);
if (readModule(1, (numColumns - 1), numRows, numColumns)) then
currentByte := (currentByte or 1);
currentByte := (currentByte shl 1);
if (readModule(2, (numColumns - 1), numRows, numColumns)) then
currentByte := (currentByte or 1);
currentByte := (currentByte shl 1);
if (readModule(3, (numColumns - 1), numRows, numColumns)) then
currentByte := (currentByte or 1);
Result := currentByte;
end;
function TBitMatrixParser.readCorner2(numRows, numColumns: Integer): Integer;
var
currentByte: Byte;
begin
currentByte := 0;
if (readModule((numRows - 3), 0, numRows, numColumns)) then
currentByte := (currentByte or 1);
currentByte := (currentByte shl 1);
if (readModule((numRows - 2), 0, numRows, numColumns)) then
currentByte := (currentByte or 1);
currentByte := (currentByte shl 1);
if (readModule((numRows - 1), 0, numRows, numColumns)) then
currentByte := (currentByte or 1);
currentByte := (currentByte shl 1);
if (readModule(0, (numColumns - 4), numRows, numColumns)) then
currentByte := (currentByte or 1);
currentByte := (currentByte shl 1);
if (readModule(0, (numColumns - 3), numRows, numColumns)) then
currentByte := (currentByte or 1);
currentByte := (currentByte shl 1);
if (readModule(0, (numColumns - 2), numRows, numColumns)) then
currentByte := (currentByte or 1);
currentByte := (currentByte shl 1);
if (readModule(0, (numColumns - 1), numRows, numColumns)) then
currentByte := (currentByte or 1);
currentByte := (currentByte shl 1);
if (readModule(1, (numColumns - 1), numRows, numColumns)) then
currentByte := (currentByte or 1);
Result := currentByte;
end;
function TBitMatrixParser.readCorner3(numRows, numColumns: Integer): Integer;
var
currentByte: Byte;
begin
currentByte := 0;
if (readModule((numRows - 1), 0, numRows, numColumns)) then
currentByte := (currentByte or 1);
currentByte := (currentByte shl 1);
if (readModule((numRows - 1), (numColumns - 1), numRows, numColumns)) then
currentByte := (currentByte or 1);
currentByte := (currentByte shl 1);
if (readModule(0, (numColumns - 3), numRows, numColumns)) then
currentByte := (currentByte or 1);
currentByte := (currentByte shl 1);
if (readModule(0, (numColumns - 2), numRows, numColumns)) then
currentByte := (currentByte or 1);
currentByte := (currentByte shl 1);
if (readModule(0, (numColumns - 1), numRows, numColumns)) then
currentByte := (currentByte or 1);
currentByte := (currentByte shl 1);
if (readModule(1, (numColumns - 3), numRows, numColumns)) then
currentByte := (currentByte or 1);
currentByte := (currentByte shl 1);
if (readModule(1, (numColumns - 2), numRows, numColumns)) then
currentByte := (currentByte or 1);
currentByte := (currentByte shl 1);
if (readModule(1, (numColumns - 1), numRows, numColumns)) then
currentByte := (currentByte or 1);
Result := currentByte;
end;
function TBitMatrixParser.readCorner4(numRows, numColumns: Integer): Integer;
var
currentByte: Byte;
begin
currentByte := 0;
if (readModule((numRows - 3), 0, numRows, numColumns)) then
currentByte := (currentByte or 1);
currentByte := (currentByte shl 1);
if (readModule((numRows - 2), 0, numRows, numColumns)) then
currentByte := (currentByte or 1);
currentByte := (currentByte shl 1);
if (readModule((numRows - 1), 0, numRows, numColumns)) then
currentByte := (currentByte or 1);
currentByte := (currentByte shl 1);
if (self.readModule(0, (numColumns - 2), numRows, numColumns)) then
currentByte := (currentByte or 1);
currentByte := (currentByte shl 1);
if (readModule(0, (numColumns - 1), numRows, numColumns)) then
currentByte := (currentByte or 1);
currentByte := (currentByte shl 1);
if (readModule(1, (numColumns - 1), numRows, numColumns)) then
currentByte := (currentByte or 1);
currentByte := (currentByte shl 1);
if (readModule(2, (numColumns - 1), numRows, numColumns)) then
currentByte := (currentByte or 1);
currentByte := (currentByte shl 1);
if (readModule(3, (numColumns - 1), numRows, numColumns)) then
currentByte := (currentByte or 1);
Result := currentByte;
end;
function TBitMatrixParser.extractDataRegion(BitMatrix: TBitMatrix): TBitMatrix;
var
i, j, symbolSizeRows, dataRegionSizeRows,
dataRegionSizeColumns, numDataRegionsRow, numDataRegionsColumn,
sizeDataRegionRow, sizeDataRegionColumn, dataRegionRow, dataRegionRowOffset,
dataRegionColumn, dataRegionColumnOffset, readRowOffset, writeRowOffset,
readColumnOffset, writeColumnOffset: Integer;
bitMatrixWithoutAlignment: TBitMatrix;
begin
symbolSizeRows := Version.symbolSizeRows;
if (BitMatrix.Height <> symbolSizeRows) then
raise EArgumentException.Create
('Dimension of bitMarix must match the version size');
dataRegionSizeRows := Version.dataRegionSizeRows;
dataRegionSizeColumns := Version.dataRegionSizeColumns;
numDataRegionsRow := (symbolSizeRows div dataRegionSizeRows);
numDataRegionsColumn := (Version.symbolSizeColumns div dataRegionSizeColumns);
sizeDataRegionRow := (numDataRegionsRow * dataRegionSizeRows);
sizeDataRegionColumn := (numDataRegionsColumn * dataRegionSizeColumns);
bitMatrixWithoutAlignment := TBitMatrix.Create(sizeDataRegionColumn,
sizeDataRegionRow);
for dataRegionRow := 0 to Pred(numDataRegionsRow) do
begin
dataRegionRowOffset := (dataRegionRow * dataRegionSizeRows);
for dataRegionColumn := 0 to Pred(numDataRegionsColumn) do
begin
dataRegionColumnOffset := (dataRegionColumn * dataRegionSizeColumns);
for i := 0 to Pred(dataRegionSizeRows) do
begin
readRowOffset := (dataRegionRow * (dataRegionSizeRows + 2)) + 1 + i;
writeRowOffset := (dataRegionRowOffset + i);
for j := 0 to Pred(dataRegionSizeColumns) do
begin
readColumnOffset :=
(dataRegionColumn * (dataRegionSizeColumns + 2)) + 1 + j;
if (BitMatrix[readColumnOffset, readRowOffset]) then
begin
writeColumnOffset := (dataRegionColumnOffset + j);
bitMatrixWithoutAlignment[writeColumnOffset,
writeRowOffset] := true;
end;
end;
end;
end;
end;
Result := bitMatrixWithoutAlignment;
end;
end.
@@ -0,0 +1,179 @@
{
* Copyright 2008 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Original Author: bbrown@google.com (Brian Brown)
* Delphi Implementation by K. Gossens
}
unit ZXing.Datamatrix.Internal.DataBlock;
interface
uses
System.SysUtils,
ZXing.Datamatrix.Internal.Version;
type
/// <summary>
/// <p>Encapsulates a block of data within a Data Matrix Code. Data Matrix Codes may split their data into
/// multiple blocks, each of which is a unit of data and error-correction codewords. Each
/// is represented by an instance of this class.</p>
/// </summary>
TDataBlock = class sealed
private
Fcodewords: TArray<Byte>;
FNumDataCodewords: Integer;
public
constructor Create(const Acodewords: TArray<Byte>;
const ANumDataCodewords: Integer);
destructor Destroy;override;
class function getDataBlocks(rawCodewords: TArray<Byte>;
version: TVersion): TArray<TDataBlock>;
property codewords: TArray<Byte> read Fcodewords;
property NumDataCodewords: Integer read FNumDataCodewords;
end;
implementation
{ TDataBlock }
constructor TDataBlock.Create(const Acodewords: TArray<Byte>;
const ANumDataCodewords: Integer);
begin
FnumDataCodewords := AnumDataCodewords;
Fcodewords := Acodewords;
end;
destructor TDataBlock.Destroy;
begin
Fcodewords := nil;
inherited;
end;
class function TDataBlock.getDataBlocks(rawCodewords: TArray<Byte>;
version: TVersion): TArray<TDataBlock>;
var
i, j: Integer;
ecBlock : TVersion.TECB;
ecBlocks : TVersion.TECBlocks;
totalBlocks : Integer;
ecBlockArray : TArray<TVersion.TECB>;
byteArray : TArray<Byte>;
numResultBlocks,
numDataCodewords,
numBlockCodewords,
longerBlocksTotalCodewords,
//shorterBlocksTotalCodewords
longerBlocksNumDataCodewords,
shorterBlocksNumDataCodewords,
rawCodewordsOffset,
numLongerBlocks,
max,
iOffset,
jOffset : Integer;
specialVersion: Boolean;
begin
// Figure out the number and size of data blocks used by this version
ecBlocks := version.ecBlocks;
// First count the total number of data blocks
totalBlocks := 0;
ecBlockArray := ecBlocks.ECBBlocksValue;
for ecBlock in ecBlockArray do
begin
inc(totalBlocks, ecBlock.Count)
end;
// Now establish DataBlocks of the appropriate size and number of data codewords
result := TArray<TDataBlock>.Create();
SetLength(result, totalBlocks);
numResultBlocks := 0;
for ecBlock in ecBlockArray do
begin
for i := 0 to Pred(ecBlock.Count) do
begin
numDataCodewords := ecBlock.DataCodewords;
numBlockCodewords := (ecBlocks.ECCodewords + numDataCodewords);
byteArray := TArray<Byte>.Create();
SetLength(byteArray, numBlockCodewords);
result[numResultBlocks] := TDataBlock.Create(byteArray, numDataCodewords);
Inc(numResultBlocks);
end
end;
// All blocks have the same amount of data, except that the last n
// (where n may be 0) have 1 less byte. Figure out where these start.
// TODO: There is only one case where there is a difference for Data Matrix for size 144
longerBlocksTotalCodewords := Length(result[0].codewords);
//shorterBlocksTotalCodewords := (longerBlocksTotalCodewords - 1);
longerBlocksNumDataCodewords := (longerBlocksTotalCodewords - ecBlocks.ECCodewords);
shorterBlocksNumDataCodewords := (longerBlocksNumDataCodewords - 1);
// The last elements of result may be 1 element shorter for 144 matrix
// first fill out as many elements as all of them have minus 1
rawCodewordsOffset := 0;
for i := 0 to Pred(shorterBlocksNumDataCodewords) do
begin
for j := 0 to Pred(numResultBlocks) do
begin
result[j].codewords[i] := rawCodewords[rawCodewordsOffset];
Inc(rawCodewordsOffset);
end;
end;
// Fill out the last data block in the longer ones
specialVersion := (version.versionNumber = 24);
if specialVersion
then
numLongerBlocks := 8
else
numLongerBlocks := numResultBlocks;
for j := 0 to Pred(numLongerBlocks) do
begin
result[j].codewords[(longerBlocksNumDataCodewords - 1)] := rawCodewords[rawCodewordsOffset];
Inc(rawCodewordsOffset);
end;
// Now add in error correction blocks
max := Length(result[0].codewords);
for i := longerBlocksNumDataCodewords to Pred(max) do
begin
for j := 0 to Pred(numResultBlocks) do
begin
if (specialVersion)
then
jOffset := (j + 8) mod numResultBlocks
else
jOffset := j;
if (specialVersion and (jOffset > 7))
then
iOffset := (i - 1)
else
iOffset := i;
result[jOffset].codewords[iOffset] := rawCodewords[rawCodewordsOffset];
Inc(rawCodewordsOffset);
end;
end;
if (not (rawCodewordsOffset = Length(rawCodewords)))
then
raise EArgumentException.Create('Arguments error');
end;
end.
@@ -0,0 +1,903 @@
{
* Copyright 2008 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Original Authors: bbrown@google.com (Brian Brown) and Sean Owen
* Delphi Implementation by K. Gossens
}
unit ZXing.Datamatrix.Internal.DecodedBitStreamParser;
interface
uses
System.SysUtils,
System.Generics.Collections,
ZXing.DecoderResult,
ZXing.ByteSegments,
ZXing.BitSource;
type
/// <summary>
/// <p>Data Matrix Codes can encode text as bits in one of several modes, and can use multiple modes
/// in one Data Matrix Code. This class decodes the bits back into text.</p>
///
/// <p>See ISO 16022:2006, 5.2.1 - 5.2.9.2</p>
/// </summary>
TDecodedBitStreamParser = class abstract
type
TMode = (PAD_ENCODE, // Not really a mode
ASCII_ENCODE, C40_ENCODE, TEXT_ENCODE, ANSIX12_ENCODE, EDIFACT_ENCODE,
BASE256_ENCODE);
private
class var C40_BASIC_SET_CHARS, C40_SHIFT2_SET_CHARS, TEXT_BASIC_SET_CHARS,
TEXT_SHIFT2_SET_CHARS, TEXT_SHIFT3_SET_CHARS: TArray<Char>;
class procedure InitializeClass;
class procedure FinalizeClass;
class function decodeC40Segment(bits: TBitSource;
res: TStringBuilder): boolean;
class function decodeTextSegment(bits: TBitSource;
res: TStringBuilder): boolean;
class function decodeAnsiX12Segment(bits: TBitSource;
res: TStringBuilder): boolean;
class function decodeEdifactSegment(bits: TBitSource;
res: TStringBuilder): boolean;
class function decodeBase256Segment(bits: TBitSource; res: TStringBuilder;
byteSegments:IByteSegments ): boolean;
class function decodeAsciiSegment(bits: TBitSource; res: TStringBuilder;
resultTrailer: TStringBuilder; var mode: TMode): boolean;
class procedure parseTwoBytes(firstByte: Integer; secondByte: Integer;
result: TArray<Integer>);
class function unrandomize255State(randomizedBase256Codeword: Integer;
base256CodewordPosition: Integer): Integer;
public
class function decode(bytes: TArray<Byte>): TDecoderResult;
end;
implementation
{ TDecodedBitStreamParser }
class function TDecodedBitStreamParser.decode(bytes: TArray<Byte>)
: TDecoderResult;
var
bits: TBitSource;
res, resultTrailer: TStringBuilder;
byteSegments: IByteSegments;
mode: TMode;
begin
bits := TBitSource.Create(bytes);
res := TStringBuilder.Create(100);
resultTrailer := TStringBuilder.Create(0);
byteSegments := ByteSegmentsCreate;
try
byteSegments.Add(TArray<Byte>.Create()); // TODO (KG): Validation
mode := TMode.ASCII_ENCODE;
while ((mode <> TMode.PAD_ENCODE) and (bits.available() > 0)) do
begin
if (mode = TMode.ASCII_ENCODE) then
begin
if (not TDecodedBitStreamParser.decodeAsciiSegment(bits, res,
resultTrailer, mode)) then
begin
result := nil; // this line was totally missing. I assume the correct thing is to set result = nil.
exit;
end;
end
else
begin
case mode of
TMode.C40_ENCODE:
begin
if (not TDecodedBitStreamParser.decodeC40Segment(bits, res)) then
begin
result := nil;
exit;
end;
end;
TMode.TEXT_ENCODE:
begin
if (not TDecodedBitStreamParser.decodeTextSegment(bits, res)) then
begin
result := nil;
exit;
end;
end;
TMode.ANSIX12_ENCODE:
begin
if (not TDecodedBitStreamParser.decodeAnsiX12Segment(bits, res))
then
begin
result := nil;
exit;
end;
end;
TMode.EDIFACT_ENCODE:
begin
if (not TDecodedBitStreamParser.decodeEdifactSegment(bits, res))
then
begin
result := nil;
exit;
end;
end;
TMode.BASE256_ENCODE:
begin
if (not TDecodedBitStreamParser.decodeBase256Segment(bits, res,
byteSegments)) then
begin
result := nil;
exit;
end;
end;
else
begin
result := nil;
exit;
end;
end;
mode := TMode.ASCII_ENCODE;
end;
end;
if (resultTrailer.Length > 0) then
res.Append(resultTrailer.ToString);
if (byteSegments.Count = 0) then
result := TDecoderResult.Create(bytes, res.ToString, nil, '')
else
result := TDecoderResult.Create(bytes, res.ToString, byteSegments, '');
finally
bits.Free;
res.Free;
resultTrailer.Free;
//
// for i := 0 to byteSegments.Count - 1 do
// begin
//
// end;
//
// byteSegments.Free;
end;
end;
/// <summary>
/// See ISO 16022:2006, 5.2.7
/// </summary>
class function TDecodedBitStreamParser.decodeAnsiX12Segment(bits: TBitSource;
res: TStringBuilder): boolean;
var
i: Integer;
cValues: TArray<Integer>;
firstByte: Integer;
cValue: Integer;
begin
// Three ANSI X12 values are encoded in a 16-bit value as
// (1600 * C1) + (40 * C2) + C3 + 1
cValues := TArray<Integer>.Create(0, 0, 0);
while (bits.available() > 0) do
begin
// If there is only one byte left then it will be encoded as ASCII
if (bits.available = 8) then
begin
result := true;
exit;
end;
firstByte := bits.readBits(8);
if (firstByte = 254) then
begin
// Unlatch codeword
result := true;
exit;
end;
TDecodedBitStreamParser.parseTwoBytes(firstByte, bits.readBits(8), cValues);
for i := 0 to 2 do
begin
cValue := cValues[i];
case cValue of
0:
begin
// X12 segment terminator <CR>
res.Append(#13);
end;
1:
begin
// X12 segment separator *
res.Append('*');
end;
2:
begin
// X12 sub-element separator >
res.Append('>');
end;
3:
begin
// space
res.Append(' ');
end;
else
begin
if (cValue < 14) then
// 0 - 9
res.Append(Char(cValue + 44))
else if (cValue < 40) then
// A - Z
res.Append(Char(cValue + 51))
else
begin
result := false;
exit;
end;
end;
end;
end;
end;;
result := true;
end;
/// <summary>
/// See ISO 16022:2006, 5.2.3 and Annex C, Table C.2
/// </summary>
class function TDecodedBitStreamParser.decodeAsciiSegment(bits: TBitSource;
res: TStringBuilder; resultTrailer: TStringBuilder; var mode: TMode): boolean;
var
oneByte: Integer;
upperShift: boolean;
value: Byte;
begin
upperShift := false;
mode := TMode.ASCII_ENCODE;
while (bits.available() > 0) do
begin
oneByte := bits.readBits(8);
if (oneByte = 0) then
begin
result := false;
exit;
end
else
begin
if (oneByte <= 128) then
begin
// ASCII data (ASCII value + 1)
if (upperShift) then
begin
Inc(oneByte, 128);
// upperShift := false;
end;
res.Append(Char(oneByte - 1));
mode := TMode.ASCII_ENCODE;
result := true;
exit;
end
else
begin
if (oneByte = 129) then
begin
// Pad
mode := TMode.PAD_ENCODE;
result := true;
exit;
end
else
begin
if (oneByte <= 229) then
begin
// 2-digit data 00-99 (Numeric Value + 130)
value := (oneByte - 130);
if (value < 10) then
// pad with '0' for single digit values
res.Append('0');
res.Append(value);
end
else
begin
if (oneByte = 230) then
begin
// Latch to C40 encodation
mode := TMode.C40_ENCODE;
result := true;
exit;
end
else
begin
if (oneByte = 231) then
begin
// Latch to Base 256 encodation
mode := TMode.BASE256_ENCODE;
result := true;
exit;
end
else
begin
if (oneByte = 232) then
begin
// FNC1
res.Append(Char(29)); // translate as ASCII 29
end
else
begin
if ((oneByte = 233) or (oneByte = 234)) then
begin
// Structured Append, Reader Programming
// Ignore these symbols for now
// throw EReaderException.Instance;
end
else
begin
if (oneByte = 235) then
begin
// Upper Shift (shift to Extended ASCII)
upperShift := true;
end
else
begin
if (oneByte = 236) then
begin
// 05 Macro
res.Append('[)>' + #$001E05 + #$001D);
res.Insert(0, #$001E + #$0004);
end
else
begin
if (oneByte = 237) then
begin
// 06 Macro
res.Append('[)>' + #$001E06 + #$001D);
res.Insert(0, #$001E + #$0004);
end
else
begin
if (oneByte = 238) then
begin
// Latch to ANSI X12 encodation
mode := TMode.ANSIX12_ENCODE;
result := true;
exit;
end
else
begin
if (oneByte = 239) then
begin
// Latch to Text encodation
mode := TMode.TEXT_ENCODE;
result := true;
exit;
end
else
begin
if (oneByte = 240) then
begin
mode := TMode.EDIFACT_ENCODE;
result := true;
exit;
end
else
begin
if (oneByte = 241) then
begin
// ECI Character
// TODO: I think we need to support ECI
// throw TReaderException.Instance;
// Ignore this symbol for now
end
else if (oneByte >= 242) then
begin
// Not to be used in ASCII encodation
// ... but work around encoders that end with 254, latch back to ASCII
if ((oneByte <> 254) or (bits.available() <> 0)) then
begin
result := false;
exit;
end;
end;
end;
end;
end;
end;
end;
end;
end;
end;
end;
end;
end;
end;
end;
end;
end;
mode := TMode.ASCII_ENCODE;
result := true;
end;
/// <summary>
/// See ISO 16022:2006, 5.2.9 and Annex B, B.2
/// </summary>
class function TDecodedBitStreamParser.decodeBase256Segment(bits: TBitSource;
res: TStringBuilder; byteSegments: IByteSegments ): boolean;
var
i, Count, codewordPosition, d1: Integer;
bytes: TArray<Byte>;
begin
// Figure out how long the Base 256 Segment is.
codewordPosition := (1 + bits.ByteOffset); // position is 1-indexed
d1 := TDecodedBitStreamParser.unrandomize255State(bits.readBits(8),
codewordPosition);
Inc(codewordPosition);
if (d1 = 0) then
// Read the remainder of the symbol
Count := (bits.available div 8)
else if (d1 < 250) then
Count := d1
else
begin
Count := ((250 * (d1 - 249)) + TDecodedBitStreamParser.unrandomize255State
(bits.readBits(8), codewordPosition));
Inc(codewordPosition);
end;
// We're seeing NegativeArraySizeException errors from users.
if (Count < 0) then
begin
result := false;
exit;
end;
bytes := TArray<Byte>.Create();
SetLength(bytes, Count);
for i := 0 to Pred(Count) do
begin
// Have seen this particular error in the wild, such as at
// http://www.bcgen.com/demo/IDAutomationStreamingDataMatrix.aspx?MODE=3&D=Fred&PFMT=3&PT=F&X=0.3&O=0&LM=0.2
if (bits.available() < 8) then
begin
result := false;
exit;
end;
bytes[i] := Byte(TDecodedBitStreamParser.unrandomize255State
(bits.readBits(8), codewordPosition));
Inc(codewordPosition);
end;
byteSegments.Add(bytes);
try
res.Append(TEncoding.GetEncoding('ISO-8859-1').GetString(bytes))
except
on uee: Exception do
raise EInvalidOpException.Create
('Platform does not support required encoding: ' + uee.Message)
end;
result := true;
end;
/// <summary>
/// See ISO 16022:2006, 5.2.5 and Annex C, Table C.1
/// </summary>
class function TDecodedBitStreamParser.decodeC40Segment(bits: TBitSource;
res: TStringBuilder): boolean;
var
i: Integer;
c40char: Char;
cValues: TArray<Integer>;
upperShift: boolean;
shift: Integer;
firstByte: Byte;
cValue: Integer;
begin
// Three C40 values are encoded in a 16-bit value as
// (1600 * C1) + (40 * C2) + C3 + 1
// TODO: The Upper Shift with C40 doesn't work in the 4 value scenario all the time
upperShift := false;
cValues := TArray<Integer>.Create(0, 0, 0);
shift := 0;
while (bits.available() > 0) do
begin
// If there is only one byte left then it will be encoded as ASCII
if (bits.available() = 8) then
begin
result := true;
exit;
end;
firstByte := bits.readBits(8);
if (firstByte = 254) then
begin
// Unlatch codeword
result := true;
exit;
end;
TDecodedBitStreamParser.parseTwoBytes(firstByte, bits.readBits(8), cValues);
for i := 0 to 2 do
begin
cValue := cValues[i];
case shift of
0:
begin
if (cValue < 3) then
shift := (cValue + 1)
else
begin
if (cValue < Length(C40_BASIC_SET_CHARS)) then
begin
c40char := C40_BASIC_SET_CHARS[cValue];
if (upperShift) then
begin
res.Append(Char(c40char) + Char(128));
upperShift := false;
end
else
res.Append(c40char);
end
else
begin
result := false;
exit;
end;
end;
end;
1:
begin
if (upperShift) then
begin
res.Append(Char(cValue) + Char(128));
upperShift := false;
end
else
res.Append(Char(cValue));
shift := 0;
end;
2:
begin
if (cValue < Length(C40_SHIFT2_SET_CHARS)) then
begin
c40char := C40_SHIFT2_SET_CHARS[cValue];
if (upperShift) then
begin
res.Append(Char(c40char) + Char(128));
upperShift := false;
end
else
res.Append(c40char);
end
else
begin
if (cValue = 27) then
// FNC1
res.Append(Char(29)) // translate as ASCII 29
else if (cValue = 30) then
// Upper Shift
upperShift := true
else
begin
result := false;
exit;
end;
end;
shift := 0;
end;
3:
begin
if (upperShift) then
begin
res.Append(Char(cValue + 254));
upperShift := false;
end
else
res.Append(Char(cValue + 96));
shift := 0;
end;
else
begin
result := false;
exit;
end;
end;
end;
end;
result := true;
end;
/// <summary>
/// See ISO 16022:2006, 5.2.8 and Annex C Table C.3
/// </summary>
class function TDecodedBitStreamParser.decodeEdifactSegment(bits: TBitSource;
res: TStringBuilder): boolean;
var
i: Integer;
edifactValue: Integer;
bitsLeft: Integer;
begin
while (bits.available() > 0) do
begin
// If there is only two or less bytes left then it will be encoded as ASCII
if (bits.available() <= 16) then
begin
result := true;
exit;
end;
for i := 0 to 3 do
begin
edifactValue := bits.readBits(6);
// Check for the unlatch character
if (edifactValue = $1F) then
begin
// 011111
// Read rest of byte, which should be 0, and stop
bitsLeft := (8 - bits.BitOffset);
if (not bitsLeft = 8) then
bits.readBits(bitsLeft);
result := true;
exit;
end;
if ((edifactValue and $20) = 0) then
begin
// no 1 in the leading (6th) bit
edifactValue := (edifactValue or $40);
// Add a leading 01 to the 6 bit binary value
end;
res.Append(Char(edifactValue));
end;
end;
result := true;
end;
/// <summary>
/// See ISO 16022:2006, 5.2.6 and Annex C, Table C.2
/// </summary>
class function TDecodedBitStreamParser.decodeTextSegment(bits: TBitSource;
res: TStringBuilder): boolean;
var
textChar: Char;
cValues: TArray<Integer>;
upperShift: boolean;
i, shift: Integer;
firstByte: Integer;
cValue: Integer;
begin
// Three Text values are encoded in a 16-bit value as
// (1600 * C1) + (40 * C2) + C3 + 1
// TODO: The Upper Shift with Text doesn't work in the 4 value scenario all the time
upperShift := false;
cValues := TArray<Integer>.Create(0, 0, 0);
shift := 0;
while (bits.available() > 0) do
begin
// If there is only one byte left then it will be encoded as ASCII
if (bits.available() = 8) then
begin
result := true;
exit;
end;
firstByte := bits.readBits(8);
if (firstByte = 254) then
begin
// Unlatch codeword
result := true;
exit;
end;
TDecodedBitStreamParser.parseTwoBytes(firstByte, bits.readBits(8), cValues);
for i := 0 to 2 do
begin
cValue := cValues[i];
case (shift) of
0:
begin
if (cValue < 3) then
shift := (cValue + 1)
else
begin
if (cValue < Length(TEXT_BASIC_SET_CHARS)) then
begin
textChar := TEXT_BASIC_SET_CHARS[cValue];
if (upperShift) then
begin
res.Append(Char(textChar) + Char(128));
upperShift := false;
end
else
res.Append(textChar);
end
else
begin
result := false;
exit;
end;
end;
end;
1:
begin
if (upperShift) then
begin
res.Append(Char(cValue + 128));
upperShift := false;
end
else
res.Append(Char(cValue));
shift := 0;
end;
2:
begin
// Shift 2 for Text is the same encoding as C40
if (cValue < Length(TEXT_SHIFT2_SET_CHARS)) then
begin
textChar := TEXT_SHIFT2_SET_CHARS[cValue];
if (upperShift) then
begin
res.Append(Char(textChar) + Char(128));
upperShift := false;
end
else
res.Append(textChar);
end
else
begin
if (cValue = 27) then
// FNC1
res.Append(Char(29)) // translate as ASCII 29
else if (cValue = 30) then
// Upper Shift
upperShift := true
else
begin
result := false;
exit;
end;
end;
shift := 0;
end;
3:
begin
if (cValue < Length(TEXT_SHIFT3_SET_CHARS)) then
begin
textChar := TEXT_SHIFT3_SET_CHARS[cValue];
if (upperShift) then
begin
res.Append(Char(textChar) + Char(128));
upperShift := false;
end
else
res.Append(textChar);
shift := 0;
end
else
begin
result := false;
exit;
end;
end;
else
begin
result := false;
exit;
end;
end;
end;
end;
result := true;
end;
class procedure TDecodedBitStreamParser.parseTwoBytes(firstByte: Integer;
secondByte: Integer; result: TArray<Integer>);
var
fullBitValue, temp: Integer;
begin
fullBitValue := (((firstByte shl 8) + secondByte) - 1);
temp := (fullBitValue div $640);
result[0] := temp;
dec(fullBitValue, (temp * $640));
temp := (fullBitValue div 40);
result[1] := temp;
result[2] := (fullBitValue - (temp * 40))
end;
/// <summary>
/// See ISO 16022:2006, Annex B, B.2
/// </summary>
class function TDecodedBitStreamParser.unrandomize255State
(randomizedBase256Codeword: Integer;
base256CodewordPosition: Integer): Integer;
var
pseudoRandomNumber: Integer;
tempVariable: Integer;
begin
pseudoRandomNumber := (((149 * base256CodewordPosition) mod 255) + 1);
tempVariable := (randomizedBase256Codeword - pseudoRandomNumber);
if (tempVariable >= 0) then
result := tempVariable
else
result := (tempVariable + 256);
end;
class procedure TDecodedBitStreamParser.InitializeClass;
begin
/// <summary>
/// See ISO 16022:2006, Annex C Table C.1
/// The C40 Basic Character Set (*'s used for placeholders for the shift values)
/// </summary>
C40_BASIC_SET_CHARS := TArray<Char>.Create('*', '*', '*', ' ', '0', '1', '2',
'3', '4', '5', '6', '7', '8', '9', 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H',
'I', 'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W',
'X', 'Y', 'Z');
C40_SHIFT2_SET_CHARS := TArray<Char>.Create('!', '"', '#', '$', '%', '&',
'''', '(', ')', '*', '+', ',', '-', '.', '/', ':', ';', '<', '=', '>', '?',
'@', '[', '\', ']', '^', '_');
/// <summary>
/// See ISO 16022:2006, Annex C Table C.2
/// The Text Basic Character Set (*'s used for placeholders for the shift values)
/// </summary>
TEXT_BASIC_SET_CHARS := TArray<Char>.Create('*', '*', '*', ' ', '0', '1', '2',
'3', '4', '5', '6', '7', '8', '9', 'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h',
'i', 'j', 'k', 'l', 'm', 'n', 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w',
'x', 'y', 'z');
// Shift 2 for Text is the same encoding as C40
TEXT_SHIFT2_SET_CHARS := C40_SHIFT2_SET_CHARS;
TEXT_SHIFT3_SET_CHARS := TArray<Char>.Create('`', 'A', 'B', 'C', 'D', 'E',
'F', 'G', 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T',
'U', 'V', 'W', 'X', 'Y', 'Z', '{', '|', '}', '~', '');
end;
class procedure TDecodedBitStreamParser.FinalizeClass;
begin
C40_BASIC_SET_CHARS := nil;
C40_SHIFT2_SET_CHARS := nil;
TEXT_BASIC_SET_CHARS := nil;
TEXT_SHIFT2_SET_CHARS := nil;
TEXT_SHIFT3_SET_CHARS := nil;
end;
initialization
TDecodedBitStreamParser.InitializeClass;
finalization
TDecodedBitStreamParser.FinalizeClass;
end.
@@ -0,0 +1,229 @@
{
* Copyright 2008 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Original Author: bbrown@google.com (Brian Brown)
* Delphi Implementation by K. Gossens
}
unit ZXing.Datamatrix.Internal.Decoder;
interface
uses
System.SysUtils,
System.Generics.Collections,
ZXing.DecodeHintType,
ZXing.Common.BitMatrix,
ZXing.Datamatrix.Internal.BitMatrixParser,
ZXing.Datamatrix.Internal.DataBlock,
ZXing.Common.ReedSolomon.ReedSolomonDecoder,
ZXing.Common.ReedSolomon.GenericGF,
ZXing.DecoderResult,
ZXing.Datamatrix.Internal.DecodedBitStreamParser;
type
/// <summary>
/// <p>The main class which implements Data Matrix Code decoding -- as opposed to locating and extracting
/// the Data Matrix Code from an image.</p>
/// </summary>
TDataMatrixDecoder = class sealed
private
rsDecoder: TReedSolomonDecoder;
public
constructor Create;
destructor Destroy; override;
function correctErrors(codewordBytes: TArray<Byte>; numDataCodewords: Integer): boolean;
function decode(bits: TBitMatrix): TDecoderResult; overload;
function decode(image: TArray < TArray < boolean >> ): TDecoderResult; overload;
end;
implementation
{ TDataMatrixDecoder }
/// <summary>
/// Initializes a new instance of the <see cref="Decoder"/> class.
/// </summary>
constructor TDataMatrixDecoder.Create;
begin
rsDecoder := TReedSolomonDecoder.Create(TGenericGF.DATA_MATRIX_FIELD_256);
end;
destructor TDataMatrixDecoder.Destroy;
begin
FreeAndNil(rsDecoder);
inherited;
end;
/// <summary>
/// <p>Convenience method that can decode a Data Matrix Code represented as a 2D array of booleans.
/// "true" is taken to mean a black module.</p>
///
/// <param name="image">booleans representing white/black Data Matrix Code modules</param>
/// <returns>text and bytes encoded within the Data Matrix Code</returns>
/// <exception cref="FormatException">if the Data Matrix Code cannot be decoded</exception>
/// <exception cref="ChecksumException">if error correction fails</exception>
/// </summary>
function TDataMatrixDecoder.decode(image: TArray < TArray < boolean >> ): TDecoderResult;
var
i, j: Integer;
dimension: Integer;
bits: TBitMatrix;
begin
dimension := Length(image);
bits := TBitMatrix.Create(dimension);
for i := 0 to Pred(dimension) do
begin
for j := 0 to Pred(dimension) do
begin
if (image[i][j]) then
bits[j, i] := true;
end;
end;
Result := decode(bits);
end;
/// <summary>
/// <p>Decodes a Data Matrix Code represented as a <see cref="BitMatrix" />. A 1 or "true" is taken
/// to mean a black module.</p>
/// </summary>
/// <param name="bits">booleans representing white/black Data Matrix Code modules</param>
/// <returns>text and bytes encoded within the Data Matrix Code</returns>
function TDataMatrixDecoder.decode(bits: TBitMatrix): TDecoderResult;
var
i, j: Integer;
db: TDataBlock;
parser: TBitMatrixParser;
codewords: TArray<Byte>;
dataBlocks: TArray<TDataBlock>;
dataBlocksCount, totalBytes: Integer;
resultBytes: TArray<Byte>;
DataBlock: TDataBlock;
codewordBytes: TArray<Byte>;
numDataCodewords: Integer;
begin
// Construct a parser and read version, error-correction level
parser := TBitMatrixParser.Create(bits);
DataBlock := nil;
try
if (parser.Version = nil) then
begin
Result := nil;
exit;
end;
// Read codewords
codewords := parser.readCodewords;
if (codewords = nil) then
begin
Result := nil;
exit;
end;
// Separate into data blocks
dataBlocks := TDataBlock.getDataBlocks(codewords, parser.Version);
dataBlocksCount := Length(dataBlocks);
// Count total number of data bytes
totalBytes := 0;
for db in dataBlocks do
begin
Inc(totalBytes, db.numDataCodewords)
end;
resultBytes := TArray<Byte>.Create();
SetLength(resultBytes, totalBytes);
// Error-correct and copy data blocks together into a stream of bytes
for j := 0 to Pred(dataBlocksCount) do
begin
DataBlock := dataBlocks[j];
codewordBytes := DataBlock.codewords;
numDataCodewords := DataBlock.numDataCodewords;
if (not correctErrors(codewordBytes, numDataCodewords)) then
begin
if Assigned(DataBlock) then
DataBlock.Free;
DataBlock := nil;
resultBytes := nil;
codewordBytes := nil;
Result := nil;
exit;
end;
for i := 0 to Pred(numDataCodewords) do
begin
// De-interlace data blocks.
resultBytes[(i * dataBlocksCount) + j] := codewordBytes[i];
end;
DataBlock.Free;
DataBlock := nil;
end;
// Decode the contents of that stream of bytes
Result := TDecodedBitStreamParser.decode(resultBytes);
finally
if Assigned(DataBlock) then
DataBlock.Free;
resultBytes := nil;
codewordBytes := nil;
parser.Free;
end;
end;
/// <summary>
/// <p>Given data and error-correction codewords received, possibly corrupted by errors, attempts to
/// correct the errors in-place using Reed-Solomon error correction.</p>
///
/// <param name="codewordBytes">data and error correction codewords</param>
/// <param name="numDataCodewords">number of codewords that are data bytes</param>
/// </summary>
function TDataMatrixDecoder.correctErrors(codewordBytes: TArray<Byte>; numDataCodewords: Integer): boolean;
var
i, numCodewords, numECCodewords: Integer;
codewordsInts: TArray<Integer>;
begin
numCodewords := Length(codewordBytes);
// First read into an array of ints
codewordsInts := TArray<Integer>.Create();
SetLength(codewordsInts, numCodewords);
for i := 0 to Pred(numCodewords) do
begin
codewordsInts[i] := (codewordBytes[i] and $FF);
end;
numECCodewords := (Length(codewordBytes) - numDataCodewords);
if (not rsDecoder.decode(codewordsInts, numECCodewords)) then
begin
Result := false;
exit;
end;
// Copy back into array of bytes -- only need to worry about the bytes that were data
// We don't care about errors in the error-correction codewords
for i := 0 to Pred(numDataCodewords) do
begin
codewordBytes[i] := Byte(codewordsInts[i]);
end;
Result := true;
end;
end.
@@ -0,0 +1,290 @@
{
* Copyright 2007 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Original Author: bbrown@google.com (Brian Brown)
* Delphi Implementation by K. Gossens
}
unit ZXing.Datamatrix.Internal.Version;
interface
uses
System.SysUtils,
ZXing.Common.BitMatrix,
ZXing.QrCode.Internal.FormatInformation,
ZXing.Common.Detector.MathUtils;
type
/// <summary>
/// The Version object encapsulates attributes about a particular
/// size Data Matrix Code.
/// </summary>
TVersion = class sealed
type
/// <summary>
/// <p>Encapsualtes the parameters for one error-correction block in one symbol version.
/// This includes the number of data codewords, and the number of times a block with these
/// parameters is used consecutively in the Data Matrix code version's format.</p>
/// </summary>
TECB = class
private
Fcount: Integer;
FdataCodewords: Integer;
public
constructor Create(count: Integer; dataCodewords: Integer);
property count: Integer read Fcount;
property dataCodewords: Integer read FdataCodewords;
end;
/// <summary>
/// <p>Encapsulates a set of error-correction blocks in one symbol version. Most versions will
/// use blocks of differing sizes within one version, so, this encapsulates the parameters for
/// each set of blocks. It also holds the number of error-correction codewords per block since it
/// will be the same across all blocks within one version.</p>
/// </summary>
TECBlocks = class
private
_ecBlocksValue: TArray<TECB>;
_ecCodewords: Integer;
public
property ECBBlocksValue: TArray<TECB> read _ecBlocksValue;
property ECCodewords: Integer read _ecCodewords;
constructor Create(ECCodewords: Integer; ecBlocks: TECB); overload;
constructor Create(ECCodewords: Integer; ecBlocks1: TECB;
ecBlocks2: TECB); overload;
destructor Destroy; override;
end;
private
FdataRegionSizeColumns: Integer;
FdataRegionSizeRows: Integer;
FecBlocks: TECBlocks;
FsymbolSizeColumns: Integer;
FsymbolSizeRows: Integer;
FtotalCodewords: Integer;
FversionNumber: Integer;
class var buildVersions: TArray<TVersion>;
class procedure ClassInit; static;
class procedure ClassFinal; static;
class function GetBuildVersions: TArray<TVersion>; static;
constructor Create(versionNumber, symbolSizeRows, symbolSizeColumns,
dataRegionSizeRows, dataRegionSizeColumns: Integer; ecBlocks: TECBlocks);
public
destructor Destroy; override;
function ToString: string; override;
class function getVersionForDimensions(numRows: Integer;
numColumns: Integer): TVersion;
property dataRegionSizeColumns: Integer read FdataRegionSizeColumns;
property dataRegionSizeRows: Integer read FdataRegionSizeRows;
property ecBlocks: TECBlocks read FecBlocks;
property symbolSizeColumns: Integer read FsymbolSizeColumns;
property symbolSizeRows: Integer read FsymbolSizeRows;
property totalCodewords: Integer read FtotalCodewords;
property versionNumber: Integer read FversionNumber;
end;
implementation
{ TVersion.TECB }
constructor TVersion.TECB.Create(count, dataCodewords: Integer);
begin
self.Fcount := count;
self.FdataCodewords := dataCodewords;
end;
{ TVersion.TECBlocks }
constructor TVersion.TECBlocks.Create(ECCodewords: Integer; ecBlocks: TECB);
begin
self._ecCodewords := ECCodewords;
self._ecBlocksValue := TArray<TECB>.Create(ecBlocks);
end;
constructor TVersion.TECBlocks.Create(ECCodewords: Integer; ecBlocks1: TECB;
ecBlocks2: TECB);
begin
self._ecCodewords := ECCodewords;
self._ecBlocksValue := TArray<TECB>.Create(ecBlocks1, ecBlocks2);
end;
destructor TVersion.TECBlocks.Destroy;
var
ecb: TECB;
i: Integer;
begin
for i := 0 to Length(_ecBlocksValue) - 1 do
begin
ecb := _ecBlocksValue[i];
FreeAndNil(ecb);
end;
_ecBlocksValue := nil;
inherited;
end;
{ TVersion }
class procedure TVersion.ClassInit();
begin
TVersion.buildVersions := TVersion.GetBuildVersions;
end;
class procedure TVersion.ClassFinal();
var
Version: TVersion;
begin
for Version in TVersion.buildVersions do
begin
Version.Free;
end;
TVersion.buildVersions := nil;
end;
constructor TVersion.Create(versionNumber, symbolSizeRows, symbolSizeColumns,
dataRegionSizeRows, dataRegionSizeColumns: Integer; ecBlocks: TECBlocks);
var
ecBlock: TECB;
total: Integer;
ECCodewords: Integer;
begin
self.FversionNumber := versionNumber;
self.FsymbolSizeRows := symbolSizeRows;
self.FsymbolSizeColumns := symbolSizeColumns;
self.FdataRegionSizeRows := dataRegionSizeRows;
self.FdataRegionSizeColumns := dataRegionSizeColumns;
self.FecBlocks := ecBlocks;
total := 0;
ECCodewords := ecBlocks.ECCodewords;
for ecBlock in ecBlocks.ECBBlocksValue do
begin
Inc(total, (ecBlock.count * (ecBlock.dataCodewords + ECCodewords)))
end;
self.FtotalCodewords := total;
end;
destructor TVersion.Destroy;
begin
FreeAndNil(FecBlocks);
inherited;
end;
/// <summary>
/// See ISO 16022:2006 5.5.1 Table 7
/// </summary>
class function TVersion.GetBuildVersions: TArray<TVersion>;
begin
Result := TArray<TVersion>.Create(TVersion.Create(1, 10, 10, 8, 8,
TECBlocks.Create(5, TECB.Create(1, 3))), TVersion.Create(2, 12, 12, 10, 10,
TECBlocks.Create(7, TECB.Create(1, 5))), TVersion.Create(3, 14, 14, 12, 12,
TECBlocks.Create(10, TECB.Create(1, 8))), TVersion.Create(4, $10, $10, 14,
14, TECBlocks.Create(12, TECB.Create(1, 12))), TVersion.Create(5, $12, $12,
$10, $10, TECBlocks.Create(14, TECB.Create(1, $12))),
TVersion.Create(6, 20, 20, $12, $12, TECBlocks.Create($12,
TECB.Create(1, $16))), TVersion.Create(7, $16, $16, 20, 20,
TECBlocks.Create(20, TECB.Create(1, 30))), TVersion.Create(8, $18, $18, $16,
$16, TECBlocks.Create($18, TECB.Create(1, $24))),
TVersion.Create(9, $1A, $1A, $18, $18, TECBlocks.Create($1C,
TECB.Create(1, $2C))), TVersion.Create(10, $20, $20, 14, 14,
TECBlocks.Create($24, TECB.Create(1, $3E))), TVersion.Create(11, $24, $24,
$10, $10, TECBlocks.Create($2A, TECB.Create(1, $56))),
TVersion.Create(12, 40, 40, $12, $12, TECBlocks.Create($30,
TECB.Create(1, $72))), TVersion.Create(13, $2C, $2C, 20, 20,
TECBlocks.Create($38, TECB.Create(1, $90))), TVersion.Create(14, $30, $30,
$16, $16, TECBlocks.Create($44, TECB.Create(1, $AE))),
TVersion.Create(15, $34, $34, $18, $18, TECBlocks.Create($2A,
TECB.Create(2, $66))), TVersion.Create($10, $40, $40, 14, 14,
TECBlocks.Create($38, TECB.Create(2, 140))), TVersion.Create($11, $48, $48,
$10, $10, TECBlocks.Create($24, TECB.Create(4, $5C))),
TVersion.Create($12, 80, 80, $12, $12, TECBlocks.Create($30,
TECB.Create(4, $72))), TVersion.Create($13, $58, $58, 20, 20,
TECBlocks.Create($38, TECB.Create(4, $90))), TVersion.Create(20, $60, $60,
$16, $16, TECBlocks.Create($44, TECB.Create(4, $AE))),
TVersion.Create($15, $68, $68, $18, $18, TECBlocks.Create($38,
TECB.Create(6, $88))), TVersion.Create($16, 120, 120, $12, $12,
TECBlocks.Create($44, TECB.Create(6, $AF))), TVersion.Create($17, $84, $84,
20, 20, TECBlocks.Create($3E, TECB.Create(8, $A3))),
TVersion.Create($18, $90, $90, $16, $16, TECBlocks.Create($3E,
TECB.Create(8, $9C), TECB.Create(2, $9B))), TVersion.Create($19, 8, $12, 6,
$10, TECBlocks.Create(7, TECB.Create(1, 5))), TVersion.Create($1A, 8, $20,
6, 14, TECBlocks.Create(11, TECB.Create(1, 10))),
TVersion.Create($1B, 12, $1A, 10, $18, TECBlocks.Create(14,
TECB.Create(1, $10))), TVersion.Create($1C, 12, $24, 10, $10,
TECBlocks.Create($12, TECB.Create(1, $16))), TVersion.Create($1D, $10, $24,
14, $10, TECBlocks.Create($18, TECB.Create(1, $20))),
TVersion.Create(30, $10, $30, 14, $16, TECBlocks.Create($1C,
TECB.Create(1, $31))));
end;
/// <summary>
/// <p>Deduces version information from Data Matrix dimensions.</p>
///
/// <param name="numRows">Number of rows in modules</param>
/// <param name="numColumns">Number of columns in modules</param>
/// <returns>Version for a Data Matrix Code of those dimensions</returns>
/// <exception cref="FormatException">if dimensions do correspond to a valid Data Matrix size</exception>
/// </summary>
class function TVersion.getVersionForDimensions(numRows: Integer;
numColumns: Integer): TVersion;
var
Version: TVersion;
begin
Result := nil;
if (((numRows and $01) = 0) and ((numColumns and $01) = 0)) then
begin
for Version in TVersion.buildVersions do
begin
if ((Version.symbolSizeRows = numRows) and
(Version.symbolSizeColumns = numColumns)) then
begin
Result := Version;
break;
end;
end;
end;
end;
function TVersion.ToString: string;
begin
Result := versionNumber.ToString();
end;
Initialization
TVersion.ClassInit();
Finalization
TVersion.ClassFinal();
end.
@@ -0,0 +1,361 @@
{
* Copyright 2007 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Original Author: Sean Owen
* Delphi Implementation by E. Spelt and K. Gossens
}
unit ZXing.QrCode.Internal.BitMatrixParser;
interface
uses
SysUtils,
Generics.Collections,
ZXing.DecodeHintType,
ZXing.Common.BitMatrix,
ZXing.QrCode.Internal.Version,
ZXing.QrCode.Internal.FormatInformation,
ZXing.Common.Detector.MathUtils,
ZXing.QrCode.Internal.DataMask;
type
TBitMatrixParser = class
private
BitMatrix: TBitMatrix;
mirrored: boolean;
parsedVersion: TVersion;
function copyBit(const i, j, versionBits: Integer): Integer;
public
parsedFormatInfo: TFormatInformation;
constructor Create(const BitMatrix: TBitMatrix);
/// <param name="bitMatrix">{@link TBitMatrix} to parse</param>
/// <throws>ReaderException if dimension is not >= 21 and 1 mod 4</throws>
class function createBitMatrixParser(
const bitMatrix: TBitMatrix): TBitMatrixParser; static;
(** Mirror the bit matrix in order to attempt a second reading. *)
procedure mirror;
(**
* Revert the mask removal done while reading the code words. The bit matrix should revert to its original state.
*)
procedure remask;
(**
* Prepare the parser for a mirrored operation.
* This flag has effect only on the {@link #readFormatInformation()} and the
* {@link #readVersion()}. Before proceeding with {@link #readCodewords()} the
* {@link #mirror()} method should be called.
*
* @param mirror Whether to read version and format information mirrored.
*)
procedure setMirror(const mirror: Boolean);
/// <summary> <p>Reads format information from one of its two locations within the QR Code.</p>
///
/// </summary>
/// <returns> {@link FormatInformation} encapsulating the QR Code's format info
/// </returns>
/// <throws> ReaderException if both format information locations cannot be parsed as </throws>
/// <summary> the valid encoding of format information
/// </summary>
function readFormatInformation: TFormatInformation;
/// <summary> <p>Reads version information from one of its two locations within the QR Code.</p>
///
/// </summary>
/// <returns> {@link Version} encapsulating the QR Code's version
/// </returns>
/// <throws> ReaderException if both version information locations cannot be parsed as </throws>
/// <summary> the valid encoding of version information
/// </summary>
function readVersion: TVersion;
// <summary> <p>Reads the bits in the {@link BitMatrix} representing the finder pattern in the
// correct order in order to reconstruct the codewords bytes contained within the
/// QR Code.</p>
///
/// </summary>
/// <returns> bytes encoded within the QR Code
/// </returns>
/// <throws> ReaderException if the exact number of bytes expected is not read </throws>
function readCodewords: TArray<Byte>;
end;
implementation
{ TBitMatrixParser }
constructor TBitMatrixParser.Create(const bitMatrix: TBitMatrix);
begin
// Should only be called from createBitMatrixParser with the important checks before
Self.bitMatrix := BitMatrix;
end;
class function TBitMatrixParser.createBitMatrixParser(
const bitMatrix: TBitMatrix): TBitMatrixParser;
var
dimension: Integer;
begin
dimension := BitMatrix.Height;
if ((dimension < 21) and ((dimension and $03) <> 1))
then
Result := nil
else
Result := TBitMatrixParser.Create(bitMatrix);
end;
function TBitMatrixParser.copyBit(const i, j, versionBits: Integer): Integer;
var
bit: Boolean;
begin
if (mirrored)
then
bit := BitMatrix[j, i]
else
bit := BitMatrix[i, j];
if (bit)
then
Result := ((versionBits shl 1) or $1)
else
Result := (versionBits shl 1);
end;
procedure TBitMatrixParser.mirror;
var
x, y: Integer;
begin
for x := 0 to Pred(bitMatrix.width) do
for y := (x + 1) to Pred(bitMatrix.height) do
if (bitMatrix[x, y] <> bitMatrix[y, x]) then
begin
bitMatrix.flip(y, x);
bitMatrix.flip(x, y);
end;
end;
function TBitMatrixParser.readCodewords: TArray<Byte>;
var
formatInfo: TFormatInformation;
dimension, resultOffset,
currentByte, bitsRead,
j, i, count, col: Integer;
functionPattern: TBitMatrix;
readingUp: boolean;
Version: TVersion;
DataMask: TDataMask;
begin
Result := nil;
formatInfo := readFormatInformation;
if (formatInfo = nil)
then
exit;
Version := readVersion;
if (Version = nil)
then
exit;
// Get the data mask for the format used in this QR Code. This will exclude
// some bits from reading as we wind through the bit matrix.
DataMask := TDataMask.forReference(formatInfo.DataMask);
dimension := bitMatrix.Height;
DataMask.unmaskBitMatrix(BitMatrix, dimension);
functionPattern := Version.buildFunctionPattern;
try
readingUp := true;
Result := TArray<Byte>.Create();
SetLength(Result, version.TotalCodewords);
resultOffset := 0;
currentByte := 0;
bitsRead := 0;
j := (dimension - 1);
// Read columns in pairs, from right to left
while ((j > 0)) do
begin
if (j = 6)
then
// Skip whole column with vertical alignment pattern;
// saves time and makes the other code proceed more cleanly
Dec(j);
// Read alternatingly from bottom to top then top to bottom
for count := 0 to Pred(dimension) do
begin
if (readingUp)
then
i := ((dimension - 1) - count)
else
i := count;
for col := 0 to Pred(2) do
begin
// Ignore bits covered by the function pattern
if (not functionPattern[(j - col), i]) then
begin
// Read a bit
Inc(bitsRead);
currentByte := (currentByte shl 1);
if (bitMatrix[(j - col), i])
then
currentByte := (currentByte or 1);
// If we've made a whole byte, save it off
if (bitsRead = 8) then
begin
// if resultoffset > high(Result) then
// raise EProgrammerNotFound.CreateFmt('resultoffset %d> high(Result) %d',[resultOffset,high(Result)])
// else if resultoffset < 0 then
// raise EProgrammerNotFound.CreateFmt('resultoffset %d<0!',[resultOffset]);
if (resultoffset>=0) and (resultoffset <= high(Result)) then // minchiata aggiunta da carlo
Result[resultOffset] := Byte(currentByte);
Inc(resultOffset);
bitsRead := 0;
currentByte := 0;
end
end;
end;
end;
readingUp := not readingUp; // readingUp = !readingUp; // switch directions
Dec(j, 2);
end;
if (resultOffset <> version.TotalCodewords)
then
Result := nil;
finally
FreeAndNil(functionPattern);
end;
end;
function TBitMatrixParser.readFormatInformation: TFormatInformation;
var
formatInfoBits1,
formatInfoBits2,
dimension,
i, j, jMin: Integer;
begin
if (Self.parsedFormatInfo <> nil) then
begin
Result := Self.parsedFormatInfo;
exit;
end;
// Read top-left format info bits
formatInfoBits1 := 0;
for i := 0 to Pred(6) do
formatInfoBits1 := self.copyBit(i, 8, formatInfoBits1);
// .. and skip a bit in the timing pattern ...
formatInfoBits1 := self.copyBit(7, 8, formatInfoBits1);
formatInfoBits1 := self.copyBit(8, 8, formatInfoBits1);
formatInfoBits1 := self.copyBit(8, 7, formatInfoBits1);
// .. and skip a bit in the timing pattern ...
for j := 5 downto 0 do
formatInfoBits1 := self.copyBit(8, j, formatInfoBits1);
// Read the top-right/bottom-left pattern too
dimension := Self.bitMatrix.Height;
formatInfoBits2 := 0;
jMin := (dimension - 7);
for j := (dimension - 1) downto jMin do
formatInfoBits2 := self.copyBit(8, j, formatInfoBits2);
for i := (dimension - 8) to Pred(dimension) do
formatInfoBits2 := self.copyBit(i, 8, formatInfoBits2);
parsedFormatInfo := TFormatInformation.DecodeFormatInformation(formatInfoBits1, formatInfoBits2);
if (parsedFormatInfo <> nil)
then
Result := Self.parsedFormatInfo
else
Result := nil;
end;
function TBitMatrixParser.readVersion: TVersion;
var
dimension,
provisionalVersion,
versionBits,
i, j, ijMin: Integer;
begin
if (Self.parsedVersion <> nil) then
begin
Result := Self.parsedVersion;
exit;
end;
dimension := Self.bitMatrix.Height;
provisionalVersion := TMathUtils.Asr((dimension - 17), 2);
if (provisionalVersion <= 6) then
begin
Result := TVersion.getVersionForNumber(provisionalVersion);
exit;
end;
// Read top-right version info: 3 wide by 6 tall
versionBits := 0;
ijMin := (dimension - 11);
for j := 5 downto 0 do
for i := (dimension - 9) downto ijMin do
versionBits := Self.copyBit(i, j, versionBits);
parsedVersion := TVersion.decodeVersionInformation(versionBits);
if ((parsedVersion <> nil) and
(parsedVersion.DimensionForVersion = dimension)) then
begin
Result := parsedVersion;
exit;
end;
// Hmm, failed. Try bottom left: 6 wide by 3 tall
versionBits := 0;
for i := 5 downto 0 do
for j := (dimension - 9) downto ijMin do
versionBits := self.copyBit(i, j, versionBits);
parsedVersion := TVersion.decodeVersionInformation(versionBits);
if ((parsedVersion <> nil) and
(parsedVersion.DimensionForVersion = dimension))
then
Result := self.parsedVersion
else
Result := nil;
end;
procedure TBitMatrixParser.remask;
var
dimension: Integer;
begin
if (parsedFormatInfo <> nil) then
begin
dimension := bitMatrix.Height;
TDataMask.forReference(parsedFormatInfo.DataMask)
.unmaskBitMatrix(bitMatrix, dimension);
end;
end;
procedure TBitMatrixParser.setMirror(const mirror: Boolean);
begin
Self.parsedVersion := nil;
Self.parsedFormatInfo := nil;
Self.mirrored := mirror;
end;
end.
@@ -0,0 +1,187 @@
{
* Copyright 2007 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Original Author: Sean Owen
* Ported from ZXING Java Source: www.Redivivus.in (suraj.supekar@redivivus.in)
* Delphi Implementation by E. Spelt and K. Gossens
}
unit ZXing.QrCode.Internal.DataBlock;
interface
uses
System.SysUtils,
ZXing.QrCode.Internal.Version,
ZXing.QrCode.Internal.ErrorCorrectionLevel;
type
/// <summary> <p>Encapsulates a block of data within a QR Code. QR Codes may split their data into
/// multiple blocks, each of which is a unit of data and error-correction codewords. Each
/// is represented by an instance of this class.</p>
/// </summary>
TDataBlock = class sealed
private
Fcodewords: TArray<Byte>;
FnumDataCodewords: Integer;
public
constructor Create(const codewords: TArray<Byte>;
const NumDataCodewords: Integer);
destructor Destroy; override;
/// <summary> <p>When QR Codes use multiple data blocks, they are actually interleaved.
/// That is, the first byte of data block 1 to n is written, then the second bytes, and so on. This
/// method will separate the data into original blocks.</p>
///
/// </summary>
/// <param name="rawCodewords">bytes as read directly from the QR Code
/// </param>
/// <param name="version">version of the QR Code
/// </param>
/// <param name="ecLevel">error-correction level of the QR Code
/// </param>
/// <returns> {@link TDataBlock}s containing original bytes, "de-interleaved" from representation in the
/// QR Code
/// </returns>
class function getDataBlocks(const rawCodewords: TArray<Byte>;
const version: TVersion; const ecLevel: TErrorCorrectionLevel): TArray<TDataBlock>; static;
property codewords : TArray<Byte> read Fcodewords;
property numDataCodewords : Integer read FnumDataCodewords;
end;
implementation
{ TDataBlock }
constructor TDataBlock.Create(const codewords: TArray<Byte>;
const numDataCodewords: Integer);
begin
Fcodewords := codewords;
FnumDataCodewords := numDataCodewords;
end;
destructor TDataBlock.Destroy;
begin
Fcodewords := nil;
inherited;
end;
class function TDataBlock.getDataBlocks(const rawCodewords: TArray<Byte>;
const version: TVersion; const ecLevel: TErrorCorrectionLevel): TArray<TDataBlock>;
var
numResultBlocks,
shorterBlocksTotalCodewords,
longerBlocksStartAt,
shorterBlocksNumDataCodewords,
max, i, j,
totalBlocks,
numBlockCodewords,
iOffset,
rawCodewordsOffset,
NumDataCodewords: Integer;
ecBlock: Tversion.TECB;
ecBlocks: Tversion.TECBlocks;
ecBlockArray: TArray<Tversion.TECB>;
numBlockCodewordsBytes: TArray<Byte>;
begin
if (Length(rawCodewords) <> Version.TotalCodewords)
then
raise EArgumentException.Create('Invalid arguments');
// Figure out the number and size of data blocks used by this version and
// error correction level
ecBlocks := version.getECBlocksForLevel(ecLevel);
// First count the total number of data blocks
totalBlocks := 0;
ecBlockArray := ecBlocks.getECBlocks;
for ecBlock in ecBlockArray do
Inc(totalBlocks, ecBlock.Count);
// Now establish DataBlocks of the appropriate size and number of data codewords
Result := TArray<TDataBlock>.Create();
SetLength(result, totalBlocks);
numResultBlocks := 0;
for ecBlock in ecBlockArray do
begin
for i := 0 to Pred(ecBlock.count) do
begin
numDataCodewords := ecBlock.DataCodewords;
numBlockCodewords := ecBlocks.ECCodewordsPerBlock + numDataCodewords;
numBlockCodewordsBytes := TArray<Byte>.Create();
SetLength(numBlockCodewordsBytes, numBlockCodewords);
Result[numResultBlocks] := TDataBlock.Create(numBlockCodewordsBytes, numDataCodewords);
Inc(numResultBlocks);
end
end;
numBlockCodewordsBytes := nil;
// All blocks have the same amount of data, except that the last n
// (where n may be 0) have 1 more byte. Figure out where these start.
shorterBlocksTotalCodewords := Length(Result[0].codewords);
longerBlocksStartAt := Length(result) - 1;
while ((longerBlocksStartAt >= 0)) do
begin
if (Length(Result[longerBlocksStartAt].codewords) = shorterBlocksTotalCodewords)
then
break;
Dec(longerBlocksStartAt);
end;
Inc(longerBlocksStartAt);
shorterBlocksNumDataCodewords := (shorterBlocksTotalCodewords - ecBlocks.ECCodewordsPerBlock);
// The last elements of result may be 1 element longer;
// first fill out as many elements as all of them have
rawCodewordsOffset := 0;
for i := 0 to Pred(shorterBlocksNumDataCodewords) do
begin
for j := 0 to Pred(numResultBlocks) do
begin
Result[j].codewords[i] := rawCodewords[rawCodewordsOffset];
Inc(rawCodewordsOffset);
end;
end;
// Fill out the last data block in the longer ones
for j := longerBlocksStartAt to Pred(numResultBlocks) do
begin
result[j].codewords[shorterBlocksNumDataCodewords] :=
rawCodewords[rawCodewordsOffset];
Inc(rawCodewordsOffset);
end;
// Now add in error correction blocks
max := Length(result[0].codewords);
for i := shorterBlocksNumDataCodewords to Pred(max) do
begin
for j := 0 to Pred(numResultBlocks) do
begin
if (j < longerBlocksStartAt)
then
iOffset := i
else
iOffset := i + 1;
Result[j].codewords[iOffset] := rawCodewords[rawCodewordsOffset];
Inc(rawCodewordsOffset);
end;
end;
end;
end.
@@ -0,0 +1,226 @@
{
* Copyright 2007 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Original Author: Sean Owen
* Ported from ZXING Java Source: www.Redivivus.in (suraj.supekar@redivivus.in)
* Delphi Implementation by E. Spelt and K. Gossens
}
unit ZXing.QrCode.Internal.DataMask;
interface
uses
SysUtils,
ZXing.Common.BitMatrix,
ZXing.Common.Detector.MathUtils;
type
/// <summary> <p>Encapsulates data masks for the data bits in a QR code, per ISO 18004:2006 6.8. Implementations
/// of this class can un-mask a raw BitMatrix. For simplicity, they will unmask the entire BitMatrix,
/// including areas used for finder patterns, timing patterns, etc. These areas should be unused
/// after the point they are unmasked anyway.</p>
///
/// <p>Note that the diagram in section 6.8.1 is misleading since it indicates that i is column position
/// and j is row position. In fact, as the text says, i is row position and j is column position.</p>
/// </summary>
TDataMask = class abstract
private
/// <summary> See ISO 18004:2006 6.8.1</summary>
class var DATA_MASKS: TArray<TDataMask>;
class procedure InitializeClass;
class procedure FinalizeClass;
function isMasked(const i, j: Integer): Boolean; virtual; abstract;
public
/// <param name="reference">a value between 0 and 7 indicating one of the eight possible
/// data mask patterns a QR Code may use
/// </param>
/// <returns> {@link DataMask} encapsulating the data mask pattern
/// </returns>
class function forReference(const reference: Integer): TDataMask; static;
/// <summary> <p>Implementations of this method reverse the data masking process applied to a QR Code and
/// make its bits ready to read.</p>
/// </summary>
/// <param name="bits">representation of QR Code bits
/// </param>
/// <param name="dimension">dimension of QR Code, represented by bits, being unmasked
/// </param>
procedure unmaskBitMatrix(const bits: TBitMatrix; const dimension: Integer);
end;
/// <summary> 000: mask bits for which (x + y) mod 2 == 0</summary>
TDataMask000 = class(TDataMask)
private
function isMasked(const i, j: Integer): Boolean; override;
end;
/// <summary> 001: mask bits for which x mod 2 == 0</summary>
TDataMask001 = class sealed(TDataMask)
private
function isMasked(const i, j: Integer): Boolean; override;
end;
/// <summary> 010: mask bits for which y mod 3 == 0</summary>
TDataMask010 = class sealed(TDataMask)
private
function isMasked(const i, j: Integer): Boolean; override;
end;
/// <summary> 011: mask bits for which (x + y) mod 3 == 0</summary>
TDataMask011 = class sealed(TDataMask)
private
function isMasked(const i, j: Integer): Boolean; override;
end;
/// <summary> 100: mask bits for which (x/2 + y/3) mod 2 == 0</summary>
TDataMask100 = class sealed(TDataMask)
private
function isMasked(const i, j: Integer): Boolean; override;
end;
/// <summary> 101: mask bits for which xy mod 2 + xy mod 3 == 0</summary>
TDataMask101 = class sealed(TDataMask)
private
function isMasked(const i, j: Integer): Boolean; override;
end;
/// <summary> 110: mask bits for which (xy mod 2 + xy mod 3) mod 2 == 0</summary>
TDataMask110 = class sealed(TDataMask)
private
function isMasked(const i, j: Integer): Boolean; override;
end;
/// <summary> 111: mask bits for which ((x+y)mod 2 + xy mod 3) mod 2 == 0</summary>
TDataMask111 = class sealed(TDataMask)
private
function isMasked(const i, j: Integer): Boolean; override;
end;
implementation
{ TDataMask }
class procedure TDataMask.InitializeClass;
begin
TDataMask.DATA_MASKS := TArray<TDataMask>.Create(TDataMask000.Create,
TDataMask001.Create,
TDataMask010.Create,
TDataMask011.Create,
TDataMask100.Create,
TDataMask101.Create,
TDataMask110.Create,
TDataMask111.Create);
end;
class procedure TDataMask.FinalizeClass;
var
dam: TDataMask;
begin
for dam in TDataMask.DATA_MASKS do
dam.Free;
DATA_MASKS := nil;
end;
class function TDataMask.forReference(const reference: Integer): TDataMask;
begin
if ((reference < 0) or (reference > 7))
then
raise EArgumentException.Create('Invalid arguments');
Result := TDataMask.DATA_MASKS[reference];
end;
procedure TDataMask.unmaskBitMatrix(const bits: TBitMatrix;
const dimension: Integer);
var
i, j: Integer;
begin
for i := 0 to Pred(dimension) do
for j := 0 to Pred(dimension) do
if (self.isMasked(i, j))
then
bits.flip(j, i);
end;
{ TDataMask000 }
function TDataMask000.isMasked(const i, j: Integer): Boolean;
begin
Result := ((i + j) and $01) = 0;
end;
{ TDataMask001 }
function TDataMask001.isMasked(const i, j: Integer): Boolean;
begin
Result := (i and $01) = 0;
end;
{ TDataMask010 }
function TDataMask010.isMasked(const i, j: Integer): Boolean;
begin
Result := (j mod 3) = 0;
end;
{ TDataMask011 }
function TDataMask011.isMasked(const i, j: Integer): Boolean;
begin
Result := (((i + j) mod 3) = 0)
end;
{ TDataMask100 }
function TDataMask100.isMasked(const i, j: Integer): Boolean;
begin
Result := (( TMathUtils.Asr(UInt32(i),1) + (j div 3)) and $01) = 0;
end;
{ TDataMask101 }
function TDataMask101.isMasked(const i, j: Integer): Boolean;
var
temp: Integer;
begin
temp := (i * j);
Result := ((temp and $01) + (temp mod 3)) = 0;
end;
{ TDataMask110 }
function TDataMask110.isMasked(const i, j: Integer): Boolean;
var
temp: Integer;
begin
temp := (i * j);
Result := (((temp and $01) + (temp mod 3)) and 1) = 0;
end;
{ TDataMask111 }
function TDataMask111.isMasked(const i, j: Integer): Boolean;
begin
Result := ((((i + j) and $01) + ((i * j) mod 3)) and $01) = 0;
end;
initialization
TDataMask.InitializeClass;
finalization
TDataMask.FinalizeClass;
end.
@@ -0,0 +1,587 @@
{
* Copyright 2007 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Original Author: Sean Owen
* Delphi Implementation by E. Spelt and K. Gossens
}
unit ZXing.QrCode.Internal.DecodedBitStreamParser;
interface
uses
ZXing.BitSource,
SysUtils,
ZXing.DecodeHintType,
Generics.Collections,
ZXing.QrCode.Internal.ErrorCorrectionLevel,
ZXing.QrCode.Internal.Version,
ZXing.DecoderResult,
ZXing.CharacterSetECI,
ZXing.StringUtils,
ZXing.ByteSegments,
ZXing.QrCode.Internal.Mode,
ZXing.Common.Detector.MathUtils;
type
/// <summary> <p>QR Codes can encode text as bits in one of several modes, and can use multiple modes
/// in one QR Code. This class decodes the bits back into text.</p>
///
/// <p>See ISO 18004:2006, 6.4.3 - 6.4.7</p>
/// </summary>
TDecodedBitStreamParser = class abstract
private
/// <summary>
/// See ISO 18004:2006, 6.4.4 Table 5
/// </summary>
class var ALPHANUMERIC_CHARS: TArray<Char>;
const
GB2312_SUBSET: Integer = 1;
class procedure InitializeClass;
class procedure FinalizeClass;
class function decodeAlphanumericSegment(const bits: TBitSource;
const res: TStringBuilder; count: Integer;
const fc1InEffect: Boolean): Boolean; static;
class function decodeByteSegment(const bits: TBitSource;
const res: TStringBuilder; count: Integer;
const currentCharacterSetECI: TCharacterSetECI;
const byteSegments: IByteSegments;
const hints: TDictionary<TDecodeHintType, TObject>): Boolean; static;
/// <summary>
/// See specification GBT 18284-2000
/// </summary>
/// <param name="bits">The bits.</param>
/// <param name="result">The result.</param>
/// <param name="count">The count.</param>
/// <returns></returns>
class function decodeHanziSegment(const bits: TBitSource;
const res: TStringBuilder; count: Integer): Boolean; static;
class function decodeKanjiSegment(const bits: TBitSource;
const res: TStringBuilder; count: Integer): boolean; static;
class function decodeNumericSegment(const bits: TBitSource;
const res: TStringBuilder; count: Integer): Boolean; static;
class function parseECIValue(const bits: TBitSource): Integer; static;
class function toAlphaNumericChar(const value: Integer): Char; static;
public
class function decode(const bytes: TArray<Byte>; const version: TVersion;
const ecLevel: TErrorCorrectionLevel;
const hints: TDictionary<TDecodeHintType, TObject>): TDecoderResult; static;
end;
implementation
{ TDecodedBitStreamParser }
class procedure TDecodedBitStreamParser.InitializeClass;
begin
ALPHANUMERIC_CHARS := TArray<Char>.Create('0', '1', '2', '3', '4', '5', '6',
'7', '8', '9', 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', 'K', 'L',
'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z', ' ',
'$', '%', '*', '+', '-', '.', '/', ':');
end;
class procedure TDecodedBitStreamParser.FinalizeClass;
begin
ALPHANUMERIC_CHARS := nil;
end;
class function TDecodedBitStreamParser.decode(const bytes: TArray<Byte>;
const version: TVersion; const ecLevel: TErrorCorrectionLevel;
const hints: TDictionary<TDecodeHintType, TObject>): TDecoderResult;
var
Mode: TMode;
bits: TBitSource;
byteSegments: IByteSegments;
fc1InEffect: Boolean;
symbolSequence,
parityData,
count, value,
countHanzi, subSet: Integer;
currentCharacterSetECI: TCharacterSetECI;
ecstring,s: String;
res: TStringBuilder;
begin
Result := nil;
bits := TBitSource.Create(bytes);
res := TStringBuilder.Create(50);
byteSegments := ByteSegmentsCreate();
byteSegments.Capacity := 1;
symbolSequence := -1;
parityData := -1;
try
try
currentCharacterSetECI := nil;
fc1InEffect := false;
repeat
// While still another segment to read...
if (bits.available < 4)
then
// OK, assume we're done. Really, a TERMINATOR mode should have been recorded here
Mode := TMode.TERMINATOR
else
begin
try
Mode := TMode.forBits(bits.readBits(4)); // mode is encoded by 4 bits
except
on E: EArgumentException do
exit;
end;
end;
if (Mode <> TMode.TERMINATOR) then
begin
if ((Mode = TMode.FNC1_FIRST_POSITION) or
(Mode = TMode.FNC1_SECOND_POSITION)) then
begin
// We do little with FNC1 except alter the parsed result a bit according to the spec
fc1InEffect := true;
end else
begin
if (Mode = TMode.STRUCTURED_APPEND) then
begin
if (bits.available() < 16)
then
exit;
// not really supported; but sequence number and parity is added later to the result metadata
// Read next 8 bits (symbol sequence #) and 8 bits (parity data), then continue
symbolSequence := bits.readBits(8);
parityData := bits.readBits(8);
end else
begin
if (Mode = TMode.ECI) then
begin
// Count doesn't apply to ECI
value := parseECIValue(bits);
currentCharacterSetECI := TCharacterSetECI.getCharacterSetECIByValue(value);
if (currentCharacterSetECI = nil)
then
exit;
end else
begin
// First handle Hanzi mode which does not start with character count
if (Mode = TMode.HANZI) then
begin
// chinese mode contains a sub set indicator right after mode indicator
subSet := bits.readBits(4);
countHanzi := bits.readBits(Mode.getCharacterCountBits(version));
if (subSet = GB2312_SUBSET) then
begin
if (not TDecodedBitStreamParser.decodeHanziSegment(bits,
res, countHanzi))
then
exit;
end;
end else
begin
// "Normal" QR code modes:
// How many characters will follow, encoded in this mode?
count := bits.readBits(Mode.getCharacterCountBits(version));
if (Mode = TMode.NUMERIC) then
begin
if (not TDecodedBitStreamParser.decodeNumericSegment(bits,
res, count))
then
exit;
end else
begin
if (Mode = TMode.ALPHANUMERIC) then
begin
if (not TDecodedBitStreamParser.
decodeAlphanumericSegment(bits, res, count, fc1InEffect))
then
exit;
end else
begin
if (Mode = TMode.BYTE) then
begin
if (not TDecodedBitStreamParser.
decodeByteSegment(bits, res, count,
currentCharacterSetECI, byteSegments, hints))
then
exit;
end else
begin
if (Mode <> TMode.KANJI) then
begin
if (not TDecodedBitStreamParser.
decodeKanjiSegment(bits, res, count))
then
exit;
end else exit;
end;
end;
end;
end;
end;
end;
end;
end;
until (Mode = TMode.TERMINATOR)
except
on E: EArgumentException do
exit;
end;
if (byteSegments.count = 0)
then
byteSegments := nil;
if (ecLevel = nil)
then
ecstring := ''
else
ecstring := ecLevel.toString();
s:= res.toString.Replace(#13+#10, #10).Replace(#10, #13);
Result := TDecoderResult.Create(bytes, s, byteSegments, ecstring, symbolSequence,
parityData);
finally
// FreeAndNil(byteSegments);
res.Clear();
FreeAndNil(res);
FreeAndNil(bits);
end;
end;
class function TDecodedBitStreamParser.decodeAlphanumericSegment(
const bits: TBitSource; const res: TStringBuilder; count: Integer;
const fc1InEffect: Boolean): Boolean;
var
start, i, nextTwoCharsBits: Integer;
charArray: TArray<Char>;
begin
Result := false;
// Read two characters at a time
start := res.Length;
while ((count > 1)) do
begin
if (bits.available < 11)
then
exit;
nextTwoCharsBits := bits.readBits(11);
res.Append(TDecodedBitStreamParser.toAlphaNumericChar
((nextTwoCharsBits div 45)));
res.Append(TDecodedBitStreamParser.toAlphaNumericChar
((nextTwoCharsBits mod 45)));
Dec(count, 2);
end;
if (count = 1) then
begin
// special case: one character left
if (bits.available < 6)
then
exit;
res.Append(TDecodedBitStreamParser.toAlphaNumericChar(bits.readBits(6)))
end;
// See section 6.4.8.1, 6.4.8.2
if (fc1InEffect) then
begin
// We need to massage the result a bit if in an FNC1 mode:
for i := start to Pred(res.Length) do
begin
if (res.Chars[i] = '%') then
begin
if ((i < (res.Length - 1)) and (res.Chars[(i + 1)] = '%'))
then
// %% is rendered as %
res.Remove((i + 1), 1)
else
begin
// In alpha mode, % should be converted to FNC1 separator 0x1D
res.Remove(i, 1);
charArray := TArray<Char>.Create(Char($1D));
res.Insert(i, charArray);
end;
end;
end;
end;
Result := true;
end;
class function TDecodedBitStreamParser.decodeByteSegment(const bits: TBitSource;
const res: TStringBuilder; count: Integer;
const currentCharacterSetECI: TCharacterSetECI;
const byteSegments: IByteSegments;
const hints: TDictionary<TDecodeHintType, TObject>): Boolean;
var
Enc:TEncoding;
encodingS, s: string;
readBytes: TArray<Byte>;
i: Integer;
begin
Result := false;
// Don't crash trying to read more bits than we have available.
if ((count shl 3) > bits.available)
then
exit;
readBytes := TArray<Byte>.Create();
SetLength(readBytes, count);
for i := 0 to Pred(count) do
readBytes[i] := Byte(bits.readBits(8));
if (currentCharacterSetECI = nil)
then
// The spec isn't clear on this mode; see
// section 6.4.5: t does not say which encoding to assuming
// upon decoding. I have seen ISO-8859-1 used as well as
// Shift_JIS -- without anything like an ECI designator to
// give a hint.
encodingS := TStringUtils.guessEncoding(readBytes, hints)
else
encodingS := currentCharacterSetECI.EncodingName;
try
enc := TEncoding.GetEncoding(encodingS);
try
s := enc.GetString(readBytes, 0, Length(readBytes));
res.Append(s);
finally
FreeAndNil(enc);
end;
except
on E: Exception do
exit;
end;
byteSegments.Add(readBytes);
result := true;
end;
class function TDecodedBitStreamParser.decodeHanziSegment(
const bits: TBitSource; const res: TStringBuilder; count: Integer): Boolean;
var
buffer: TArray<Byte>;
offset, twoBytes,
assembledTwoBytes: Integer;
begin
Result := false;
// Don't crash trying to read more bits than we have available.
if ((count * 13) > bits.available)
then
exit;
// Each character will require 2 bytes. Read the characters as 2-byte pairs
// and decode as GB2312 afterwards
buffer := TArray<Byte>.Create();
SetLength(buffer, 2 * count);
offset := 0;
while ((count > 0)) do
begin
// Each 13 bits encodes a 2-byte character
twoBytes := bits.readBits(13);
assembledTwoBytes := (((twoBytes div $60) shl 8) or (twoBytes mod $60));
if (assembledTwoBytes < $00A00)
then
// In the 0xA1A1 to 0xAAFE range
Inc(assembledTwoBytes, $0A1A1)
else
// In the 0xB0A1 to 0xFAFE range
Inc(assembledTwoBytes, $0A6A1);
buffer[offset] := Byte(TMathUtils.Asr(assembledTwoBytes, 8) and $FF);
buffer[(offset + 1)] := Byte(assembledTwoBytes and $FF);
Inc(offset, 2);
Dec(count);
end;
try
res.Append(Tencoding.GetEncoding(TStringUtils.GB2312).GetString(buffer, 0,
Length(buffer)))
except
on E: Exception do
exit;
end;
Result := true;
end;
class function TDecodedBitStreamParser.decodeKanjiSegment(
const bits: TBitSource; const res: TStringBuilder; count: Integer): Boolean;
var
buffer: TArray<Byte>;
twoBytes, offset,
assembledTwoBytes: Integer;
begin
Result := false;
// Don't crash trying to read more bits than we have available.
if ((count * 13) > bits.available)
then
exit;
// Each character will require 2 bytes. Read the characters as 2-byte pairs
// and decode as Shift_JIS afterwards
buffer := TArray<Byte>.Create();
SetLength(buffer, 2 * count);
offset := 0;
while ((count > 0)) do
begin
// Each 13 bits encodes a 2-byte character
twoBytes := bits.readBits(13);
assembledTwoBytes := (((twoBytes div $0C0) shl 8) or (twoBytes mod $0C0));
if (assembledTwoBytes < $1F00)
then
// In the 0x8140 to 0x9FFC range
Inc(assembledTwoBytes, $08140)
else
Inc(assembledTwoBytes, $0C140);
buffer[offset] := Byte( TMathUtils.Asr(assembledTwoBytes,8));
buffer[(offset + 1)] := Byte(assembledTwoBytes);
Inc(offset, 2);
Dec(count);
end;
try
res.Append(Tencoding.GetEncoding(TStringUtils.SHIFT_JIS).GetString(buffer,
0, Length(buffer)))
except
on E: Exception do
exit;
end;
Result := true;
end;
class function TDecodedBitStreamParser.decodeNumericSegment(
const bits: TBitSource; const res: TStringBuilder; count: Integer): Boolean;
var
threeDigitsBits,
twoDigitsBits,
digitBits: Integer;
begin
Result := false;
// Read three digits at a time
while ((count >= 3)) do
begin
if (bits.available < 10)
then
exit;
threeDigitsBits := bits.readBits(10);
if (threeDigitsBits >= 1000)
then
exit;
res.Append(TDecodedBitStreamParser.toAlphaNumericChar
((threeDigitsBits div 100)));
res.Append(TDecodedBitStreamParser.toAlphaNumericChar
(((threeDigitsBits div 10) mod 10)));
res.Append(TDecodedBitStreamParser.toAlphaNumericChar
((threeDigitsBits mod 10)));
Dec(count, 3)
end;
if (count = 2) then
begin
// Two digits left over to read, encoded in 7 bits
if (bits.available < 7)
then
exit;
twoDigitsBits := bits.readBits(7);
if (twoDigitsBits >= 100)
then
exit;
res.Append(TDecodedBitStreamParser.toAlphaNumericChar
((twoDigitsBits div 10)));
res.Append(TDecodedBitStreamParser.toAlphaNumericChar
((twoDigitsBits mod 10)));
end else
begin
if (count = 1) then
begin
// One digit left over to read
if (bits.available < 4)
then
exit;
digitBits := bits.readBits(4);
if (digitBits >= 10)
then
exit;
res.Append(TDecodedBitStreamParser.toAlphaNumericChar(digitBits))
end;
end;
Result := true;
end;
class function TDecodedBitStreamParser.parseECIValue(
const bits: TBitSource): Integer;
var
firstByte,
secondByte,
SecondThirdBytes: Integer;
begin
firstByte := bits.readBits(8);
if ((firstByte and $80) = 0) then
begin
// just one byte
Result := (firstByte and $7F);
exit;
end;
if ((firstByte and $C0) = $80) then
begin
// two bytes
secondByte := bits.readBits(8);
Result := (((firstByte and $3F) shl 8) or secondByte);
exit;
end;
if ((firstByte and $E0) = $C0) then
begin
// three bytes
SecondThirdBytes := bits.readBits(16);
Result := (((firstByte and $1F) shl 16) or SecondThirdBytes);
exit;
end;
raise EArgumentException.Create('Bad ECI bits starting with byte ' +
firstByte.toString());
end;
class function TDecodedBitStreamParser.toAlphaNumericChar(
const value: Integer): Char;
begin
if (value >= Length(ALPHANUMERIC_CHARS))
then
raise Exception.Create('Format exception');
Result := ALPHANUMERIC_CHARS[value];
end;
initialization
TDecodedBitStreamParser.InitializeClass;
finalization
TDecodedBitStreamParser.FinalizeClass;
end.
@@ -0,0 +1,278 @@
{
* Copyright 2007 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Original Author: Sean Owen
* Delphi Implementation by E.Spelt and K. Gossens
}
unit ZXing.QrCode.Internal.Decoder;
interface
uses
System.SysUtils,
System.Generics.Collections,
ZXing.DecodeHintType,
ZXing.Common.BitMatrix,
ZXing.QrCode.Internal.BitMatrixParser,
ZXing.DecoderResult,
ZXing.Common.ReedSolomon.ReedSolomonDecoder,
ZXing.Common.ReedSolomon.GenericGF,
ZXing.QrCode.Internal.QRCodeDecoderMetaData,
ZXing.QrCode.Internal.Version,
ZXing.QrCode.Internal.FormatInformation,
ZXing.QrCode.Internal.ErrorCorrectionLevel,
ZXing.QrCode.Internal.DataBlock,
ZXing.QrCode.Internal.DecodedBitStreamParser;
type
/// <summary>
/// <p>The main class which implements QR Code decoding -- as opposed to locating and extracting
/// the QR Code from an image.</p>
/// </summary>
TQRDecoder = class
private
rsDecoder: TReedSolomonDecoder;
/// <summary>
/// <p>Given data and error-correction codewords received, possibly corrupted by errors, attempts to
/// correct the errors in-place using Reed-Solomon error correction.</p>
/// </summary>
/// <param name="codewordBytes">data and error correction codewords</param>
/// <param name="numDataCodewords">number of codewords that are data bytes</param>
/// <returns></returns>
function correctErrors(const codewordBytes: TArray<Byte>;
const numDataCodewords: Integer): Boolean;
function decode(const parser: TBitMatrixParser;
const hints: TDictionary<TDecodeHintType, TObject>)
: TDecoderResult; overload;
public
/// <summary>
/// Initializes a new instance of the <see cref="Decoder"/> class.
/// </summary>
constructor Create;
destructor Destroy; override;
/// <summary>
/// <p>Convenience method that can decode a QR Code represented as a 2D array of booleans.
/// "true" is taken to mean a black module.</p>
/// </summary>
/// <param name="image">booleans representing white/black QR Code modules</param>
/// <param name="hints">decoding hints that should be used to influence decoding</param>
/// <returns>
/// text and bytes encoded within the QR Code
/// </returns>
function decode(const image: TArray<TArray<Boolean>>;
const hints: TDictionary<TDecodeHintType, TObject>)
: TDecoderResult; overload;
/// <summary>
/// <p>Decodes a QR Code represented as a {@link BitMatrix}. A 1 or "true" is taken to mean a black module.</p>
/// </summary>
/// <param name="bits">booleans representing white/black QR Code modules</param>
/// <param name="hints">decoding hints that should be used to influence decoding</param>
/// <returns>
/// text and bytes encoded within the QR Code
/// </returns>
function decode(const bits: TBitMatrix;
const hints: TDictionary<TDecodeHintType, TObject>)
: TDecoderResult; overload;
end;
implementation
{ TQRDecoder }
constructor TQRDecoder.Create;
begin
rsDecoder := TReedSolomonDecoder.Create(TGenericGF.QR_CODE_FIELD_256);
end;
destructor TQRDecoder.Destroy;
begin
FreeAndNil(rsDecoder);
inherited;
end;
function TQRDecoder.correctErrors(const codewordBytes: TArray<Byte>;
const numDataCodewords: Integer): Boolean;
var
i, numCodewords, numECCodewords: Integer;
codewordsInts: TArray<Integer>;
begin
Result := false;
numCodewords := Length(codewordBytes);
// First read into an array of ints
codewordsInts := TArray<Integer>.Create();
SetLength(codewordsInts, numCodewords);
for i := 0 to Pred(numCodewords) do
codewordsInts[i] := (codewordBytes[i] and $FF);
numECCodewords := Length(codewordBytes) - numDataCodewords;
if (not rsDecoder.decode(codewordsInts, numECCodewords)) then
exit;
// Copy back into array of bytes -- only need to worry about the bytes that were data
// We don't care about errors in the error-correction codewords
for i := 0 to Pred(numDataCodewords) do
codewordBytes[i] := Byte(codewordsInts[i]);
Result := true;
end;
function TQRDecoder.decode(const image: TArray<TArray<Boolean>>;
const hints: TDictionary<TDecodeHintType, TObject>): TDecoderResult;
var
dimension, i, j: Integer;
bits: TBitMatrix;
begin
dimension := Length(image);
bits := TBitMatrix.Create(dimension);
try
for i := 0 to Pred(dimension) do
for j := 0 to Pred(dimension) do
bits[j, i] := image[i][j];
Result := decode(bits, hints);
finally
bits.Free;
end;
end;
function TQRDecoder.decode(const bits: TBitMatrix;
const hints: TDictionary<TDecodeHintType, TObject>): TDecoderResult;
var
parser: TBitMatrixParser;
begin
Result := nil;
// Construct a parser and read version, error-correction level
parser := TBitMatrixParser.createBitMatrixParser(bits);
if Assigned(parser) then
begin
try
Result := decode(parser, hints);
if (Result = nil) then
begin
// Revert the bit matrix
parser.remask;
// Will be attempting a mirrored reading of the version and format info.
parser.setMirror(true);
// Preemptively read the version.
if (parser.readVersion = nil) then
exit;
// Preemptively read the format information.
if (parser.readFormatInformation = nil) then
exit;
(*
* Since we're here, this means we have successfully detected some kind
* of version and format information when mirrored. This is a good sign,
* that the QR code may be mirrored, and we should try once more with a
* mirrored content.
*)
// Prepare for a mirrored reading.
parser.mirror;
Result := decode(parser, hints);
if (Result <> nil) then
// Success! Notify the caller that the code was mirrored.
Result.Other := TQRCodeDecoderMetaData.Create(true);
end;
finally
parser.Free;
end;
end;
end;
function TQRDecoder.decode(const parser: TBitMatrixParser;
const hints: TDictionary<TDecodeHintType, TObject>): TDecoderResult;
var
DataBlock: TDataBlock;
dataBlocks: TArray<TDataBlock>;
Version: TVersion;
formatInfo: TFormatInformation;
ecLevel: TErrorCorrectionLevel;
codeWords, resultBytes, codewordBytes: TArray<Byte>;
totalBytes, resultOffset, i, numDataCodewords: Integer;
begin
Result := nil;
Version := parser.readVersion;
if (Version = nil) then
exit;
formatInfo := parser.readFormatInformation;
if (formatInfo = nil) then
exit;
ecLevel := formatInfo.ErrorCorrectionLevel;
// Read codewords
codeWords := parser.readCodewords;
if (codeWords = nil) then
begin
FreeAndNil(formatInfo);
exit;
end;
// Separate into data blocks
dataBlocks := TDataBlock.getDataBlocks(codeWords, Version, ecLevel);
// Count total number of data bytes
totalBytes := 0;
for DataBlock in dataBlocks do
Inc(totalBytes, DataBlock.numDataCodewords);
resultBytes := TArray<Byte>.Create();
SetLength(resultBytes, totalBytes);
try
resultOffset := 0;
// Error-correct and copy data blocks together into a stream of bytes
for DataBlock in dataBlocks do
begin
codewordBytes := DataBlock.codeWords;
numDataCodewords := DataBlock.numDataCodewords;
if (not self.correctErrors(codewordBytes, numDataCodewords)) then
begin
exit(nil);
end;
for i := 0 to Pred(numDataCodewords) do
begin
resultBytes[resultOffset] := codewordBytes[i];
Inc(resultOffset);
end;
end;
// Decode the contents of that stream of bytes
Result := TDecodedBitStreamParser.decode(resultBytes, Version,
ecLevel, hints);
finally
for DataBlock in dataBlocks do
DataBlock.Free;
FreeAndNil(formatInfo);
end;
end;
end.
@@ -0,0 +1,149 @@
{
* Copyright 2007 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Original Author: Sean Owen
* Delphi Implementation by E. Spelt and K. Gossens
}
unit ZXing.QrCode.Internal.ErrorCorrectionLevel;
interface
uses SysUtils;
type
/// <summary>
/// <p>See ISO 18004:2006, 6.5.1. This enum encapsulates the four error correction levels
/// defined by the QR code standard.</p>
/// </summary>
TErrorCorrectionLevel = class sealed
private
Fbits: Integer;
Fname: string;
Fordinal_Renamed_Field: Integer;
class var FOR_BITS: TArray<TErrorCorrectionLevel>;
class procedure InitalizeClass; static;
class procedure FinalizeClass; static;
public
constructor Create(const ordinal, bits: Integer; const name: String);
/// <summary>
/// Fors the bits.
/// </summary>
/// <param name="bits">int containing the two bits encoding a QR Code's error correction level</param>
/// <returns>
/// <see cref="ErrorCorrectionLevel"/> representing the encoded error correction level
/// </returns>
class function forBits(const bits: Integer): TErrorCorrectionLevel; static;
/// <summary> L = ~7% correction</summary>
class var L: TErrorCorrectionLevel;
/// <summary> M = ~15% correction</summary>
class var M: TErrorCorrectionLevel;
/// <summary> Q = ~25% correction</summary>
class var Q: TErrorCorrectionLevel;
/// <summary> H = ~30% correction</summary>
class var H: TErrorCorrectionLevel;
/// <summary>
/// Ordinals this instance.
/// </summary>
/// <returns></returns>
function ordinal: Integer;
/// <summary>
/// Returns a <see cref="System.String"/> that represents this instance.
/// </summary>
/// <returns>
/// A <see cref="System.String"/> that represents this instance.
/// </returns>
function ToString: String; override;
/// <summary>
/// Gets the bits.
/// </summary>
property Bits: Integer read Fbits;
/// <summary>
/// Gets the name.
/// </summary>
property Name: String read Fname;
end;
implementation
{ TErrorCorrectionLevel }
constructor TErrorCorrectionLevel.Create(const ordinal, bits: Integer;
const name: String);
begin
Fordinal_Renamed_Field := ordinal;
Fbits := bits;
Fname := name
end;
class procedure TErrorCorrectionLevel.InitalizeClass;
begin
H := TErrorCorrectionLevel.Create(3, 2, 'H');
L := TErrorCorrectionLevel.Create(0, 1, 'L');
M := TErrorCorrectionLevel.Create(1, 0, 'M');
Q := TErrorCorrectionLevel.Create(2, 3, 'Q');
FOR_BITS := TArray<TErrorCorrectionLevel>.Create(M, L, H, Q);
end;
class procedure TErrorCorrectionLevel.FinalizeClass;
begin
H.FOR_BITS := nil;
L.FOR_BITS := nil;
M.FOR_BITS := nil;
Q.FOR_BITS := nil;
FreeAndNil(H);
FreeAndNil(L);
FreeAndNil(M);
FreeAndNil(Q);
FOR_BITS := nil;
end;
class function TErrorCorrectionLevel.forBits(const bits: Integer): TErrorCorrectionLevel;
begin
if ((bits < 0) or
(bits >= Length(TErrorCorrectionLevel.FOR_BITS)))
then
raise EArgumentException.Create('Invalid argument');
Result := TErrorCorrectionLevel.FOR_BITS[bits];
end;
function TErrorCorrectionLevel.ordinal: Integer;
begin
Result := Fordinal_Renamed_Field;
end;
function TErrorCorrectionLevel.ToString: string;
begin
Result := Fname
end;
initialization
TErrorCorrectionLevel.InitalizeClass;
finalization
TErrorCorrectionLevel.FinalizeClass;
end.
@@ -0,0 +1,256 @@
{
* Copyright 2007 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Original Author: Sean Owen
* Ported from ZXING Java Source: www.Redivivus.in (suraj.supekar@redivivus.in)
* Delphi Implementation by E. Spelt and K. Gossens
}
unit ZXing.QrCode.Internal.FormatInformation;
interface
uses
Generics.Collections,
ZXing.QrCode.Internal.ErrorCorrectionLevel,
Classes,
ZXing.Common.Detector.MathUtils;
type
/// <summary> <p>Encapsulates a QR Code's format information, including the data mask used and
/// error correction level.</p>
///
/// </summary>
/// <seealso cref="TDataMask">
/// </seealso>
/// <seealso cref="TErrorCorrectionLevel">
/// </seealso>
TFormatInformation = class sealed
private
FErrorCorrectionLevel: TErrorCorrectionLevel;
FDataMask: Byte;
const
FORMAT_INFO_MASK_QR: Integer = $5412;
/// <summary> See ISO 18004:2006, Annex C, Table C.1</summary>
class var FORMAT_INFO_DECODE_LOOKUP: TArray<TArray<Integer>>;
/// <summary> Offset i holds the number of 1 bits in the binary representation of i</summary>
class var BITS_SET_IN_HALF_BYTE: TArray<Integer>;
class procedure InitializeClass; static;
class procedure FinalizeClass; static;
class function doDecodeFormatInformation(const maskedFormatInfo1,
maskedFormatInfo2: Integer): TFormatInformation; static;
public
constructor Create(const formatInfo: Integer);
function Equals(o: TObject): Boolean; override;
function GetHashCode: Integer; override;
class function numBitsDiffering(a, b: Integer): Integer; static;
/// <summary>
/// Decodes the format information.
/// </summary>
/// <param name="maskedFormatInfo1">format info indicator, with mask still applied</param>
/// <param name="maskedFormatInfo2">The masked format info2.</param>
/// <returns>
/// information about the format it specifies, or <code>null</code>
/// if doesn't seem to match any known pattern
/// </returns>
class function decodeFormatInformation(const maskedFormatInfo1,
maskedFormatInfo2: Integer): TFormatInformation; static;
property ErrorCorrectionLevel: TErrorCorrectionLevel
read FErrorCorrectionLevel;
property DataMask: Byte read FDataMask;
end;
implementation
{ TFormatInformation }
constructor TFormatInformation.Create(const formatInfo: Integer);
begin
// Bits 3,4
FErrorCorrectionLevel := TErrorCorrectionLevel.forBits
(TMathUtils.Asr(formatInfo, 3) and $03);
// Bottom 3 bits
FDataMask := Byte(formatInfo and 7);
end;
class function TFormatInformation.decodeFormatInformation
(const maskedFormatInfo1, maskedFormatInfo2: Integer): TFormatInformation;
var
formatInfo: TFormatInformation;
begin
formatInfo := doDecodeFormatInformation(maskedFormatInfo1, maskedFormatInfo2);
if (formatInfo <> nil) then
Result := formatInfo
else
// Should return null, but, some QR codes apparently
// do not mask this info. Try again by actually masking the pattern
// first
Result := TFormatInformation.doDecodeFormatInformation
((maskedFormatInfo1 xor FORMAT_INFO_MASK_QR),
(maskedFormatInfo2 xor FORMAT_INFO_MASK_QR));
end;
class function TFormatInformation.doDecodeFormatInformation
(const maskedFormatInfo1, maskedFormatInfo2: Integer): TFormatInformation;
var
bestDifference, bestFormatInfo, bitsDifference, targetInfo: Integer;
decodeInfo: TArray<Integer>;
begin
Result := nil;
// Find the int in FORMAT_INFO_DECODE_LOOKUP with fewest bits differing
bestDifference := High(Integer);
bestFormatInfo := 0;
for decodeInfo in FORMAT_INFO_DECODE_LOOKUP do
begin
targetInfo := decodeInfo[0];
if ((targetInfo = maskedFormatInfo1) or (targetInfo = maskedFormatInfo2))
then
begin
// Found an exact match
Result := TFormatInformation.Create(decodeInfo[1]);
exit;
end;
bitsDifference := numBitsDiffering(maskedFormatInfo1, targetInfo);
if (bitsDifference < bestDifference) then
begin
bestFormatInfo := decodeInfo[1];
bestDifference := bitsDifference;
end;
if (maskedFormatInfo1 <> maskedFormatInfo2) then
begin
// also try the other option
bitsDifference := numBitsDiffering(maskedFormatInfo2, targetInfo);
if (bitsDifference < bestDifference) then
begin
bestFormatInfo := decodeInfo[1];
bestDifference := bitsDifference;
end;
end;
end;
// Hamming distance of the 32 masked codes is 7, by construction, so <= 3 bits
// differing means we found a match
if (bestDifference <= 3) then
begin
Result := TFormatInformation.Create(bestFormatInfo);
exit;
end;
end;
function TFormatInformation.Equals(o: TObject): Boolean;
var
other: TFormatInformation;
begin
Result := false;
if (not(o is TFormatInformation)) then
exit;
other := TFormatInformation(o);
Result := ((FErrorCorrectionLevel = other.ErrorCorrectionLevel) and
(FDataMask = other.DataMask));
end;
function TFormatInformation.GetHashCode: Integer;
begin
Result := ((FErrorCorrectionLevel.ordinal shl 3) or FDataMask)
end;
class procedure TFormatInformation.InitializeClass;
begin
SetLength(FORMAT_INFO_DECODE_LOOKUP, $20);
FORMAT_INFO_DECODE_LOOKUP[0] := TArray<Integer>.Create($5412, 0);
FORMAT_INFO_DECODE_LOOKUP[1] := TArray<Integer>.Create($5125, 1);
FORMAT_INFO_DECODE_LOOKUP[2] := TArray<Integer>.Create($5E7C, 2);
FORMAT_INFO_DECODE_LOOKUP[3] := TArray<Integer>.Create($5B4B, 3);
FORMAT_INFO_DECODE_LOOKUP[4] := TArray<Integer>.Create($45F9, 4);
FORMAT_INFO_DECODE_LOOKUP[5] := TArray<Integer>.Create($40CE, 5);
FORMAT_INFO_DECODE_LOOKUP[6] := TArray<Integer>.Create($4F97, 6);
FORMAT_INFO_DECODE_LOOKUP[7] := TArray<Integer>.Create($4AA0, 7);
FORMAT_INFO_DECODE_LOOKUP[8] := TArray<Integer>.Create($77C4, 8);
FORMAT_INFO_DECODE_LOOKUP[9] := TArray<Integer>.Create($72F3, 9);
FORMAT_INFO_DECODE_LOOKUP[10] := TArray<Integer>.Create($7DAA, 10);
FORMAT_INFO_DECODE_LOOKUP[11] := TArray<Integer>.Create($789D, 11);
FORMAT_INFO_DECODE_LOOKUP[12] := TArray<Integer>.Create($662F, 12);
FORMAT_INFO_DECODE_LOOKUP[13] := TArray<Integer>.Create($6318, 13);
FORMAT_INFO_DECODE_LOOKUP[14] := TArray<Integer>.Create($6C41, 14);
FORMAT_INFO_DECODE_LOOKUP[15] := TArray<Integer>.Create($6976, 15);
FORMAT_INFO_DECODE_LOOKUP[$10] := TArray<Integer>.Create($1689, $10);
FORMAT_INFO_DECODE_LOOKUP[$11] := TArray<Integer>.Create($13BE, $11);
FORMAT_INFO_DECODE_LOOKUP[$12] := TArray<Integer>.Create($1CE7, $12);
FORMAT_INFO_DECODE_LOOKUP[$13] := TArray<Integer>.Create($19D0, $13);
FORMAT_INFO_DECODE_LOOKUP[20] := TArray<Integer>.Create($762, 20);
FORMAT_INFO_DECODE_LOOKUP[$15] := TArray<Integer>.Create($255, $15);
FORMAT_INFO_DECODE_LOOKUP[$16] := TArray<Integer>.Create($D0C, $16);
FORMAT_INFO_DECODE_LOOKUP[$17] := TArray<Integer>.Create($83B, $17);
FORMAT_INFO_DECODE_LOOKUP[$18] := TArray<Integer>.Create($355F, $18);
FORMAT_INFO_DECODE_LOOKUP[$19] := TArray<Integer>.Create($3068, $19);
FORMAT_INFO_DECODE_LOOKUP[$1A] := TArray<Integer>.Create($3F31, $1A);
FORMAT_INFO_DECODE_LOOKUP[$1B] := TArray<Integer>.Create($3A06, $1B);
FORMAT_INFO_DECODE_LOOKUP[$1C] := TArray<Integer>.Create($24B4, $1C);
FORMAT_INFO_DECODE_LOOKUP[$1D] := TArray<Integer>.Create($2183, $1D);
FORMAT_INFO_DECODE_LOOKUP[30] := TArray<Integer>.Create($2EDA, 30);
FORMAT_INFO_DECODE_LOOKUP[$1F] := TArray<Integer>.Create($2BED, $1F);
BITS_SET_IN_HALF_BYTE := TArray<Integer>.Create(0, 1, 1, 2, 1, 2, 2, 3, 1, 2,
2, 3, 2, 3, 3, 4);
end;
class procedure TFormatInformation.FinalizeClass;
var
i: Integer;
begin
for i := 0 to Pred(Length(FORMAT_INFO_DECODE_LOOKUP)) do
FORMAT_INFO_DECODE_LOOKUP[i] := nil;
FORMAT_INFO_DECODE_LOOKUP := nil;
BITS_SET_IN_HALF_BYTE := nil;
end;
class function TFormatInformation.numBitsDiffering(a, b: Integer): Integer;
begin
a := (a xor b); // a now has a 1 bit exactly where its bit differs with b's
// Count bits set quickly with a series of lookups:
Result := BITS_SET_IN_HALF_BYTE[(a and $0F)] + BITS_SET_IN_HALF_BYTE
[TMathUtils.Asr(UInt32(a), 4) and $0F] + BITS_SET_IN_HALF_BYTE
[TMathUtils.Asr(UInt32(a), 8) and $0F] + BITS_SET_IN_HALF_BYTE
[TMathUtils.Asr(UInt32(a), 12) and $0F] + BITS_SET_IN_HALF_BYTE
[TMathUtils.Asr(UInt32(a), 16) and $0F] + BITS_SET_IN_HALF_BYTE
[TMathUtils.Asr(UInt32(a), 20) and $0F] + BITS_SET_IN_HALF_BYTE
[TMathUtils.Asr(UInt32(a), 24) and $0F] + BITS_SET_IN_HALF_BYTE
[TMathUtils.Asr(UInt32(a), 28) and $0F];
end;
initialization
TFormatInformation.InitializeClass;
finalization
TFormatInformation.FinalizeClass;
end.
@@ -0,0 +1,248 @@
{
* Copyright 2007 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Original Author: Sean Owen
* Delphi Implementation by E.Spelt and K. Gossens
}
unit ZXing.QrCode.Internal.Mode;
interface
uses
System.SysUtils,
ZXing.QrCode.Internal.Version;
type
/// <summary>
/// <p>See ISO 18004:2006, 6.4.1, Tables 2 and 3. This enum encapsulates the various modes in which
/// data can be encoded to bits in the QR code standard.</p>
/// </summary>
TMode = class sealed
private
Fbits : Integer;
Fname : String;
characterCountBitsForVersions: TArray<Integer>;
class procedure InitializeClass; static;
class procedure FinalizeClass; static;
public
constructor Create(const characterCountBitsForVersions: TArray<Integer>;
const bits: Integer; const name: String); overload;
// No, we can't use an enum here. J2ME doesn't support it.
/// <summary>
///
/// </summary>
class var TERMINATOR: TMode;
/// <summary>
///
/// </summary>
class var NUMERIC: TMode;
/// <summary>
///
/// </summary>
class var ALPHANUMERIC: TMode;
/// <summary>
///
/// </summary>
class var STRUCTURED_APPEND: TMode;
/// <summary>
///
/// </summary>
class var BYTE: TMode;
/// <summary>
///
/// </summary>
class var ECI: TMode; // character counts don't apply
/// <summary>
///
/// </summary>
class var KANJI: TMode;
/// <summary>
///
/// </summary>
class var FNC1_FIRST_POSITION: TMode;
/// <summary>
///
/// </summary>
class var FNC1_SECOND_POSITION: TMode;
/// <summary>See GBT 18284-2000; "Hanzi" is a transliteration of this mode name.</summary>
class var HANZI: TMode;
/// <summary>
/// Fors the bits.
/// </summary>
/// <param name="bits">four bits encoding a QR Code data mode</param>
/// <returns>
/// <see cref="Mode"/> encoded by these bits
/// </returns>
/// <exception cref="ArgumentException">if bits do not correspond to a known mode</exception>
class function forBits(const bits: Integer): TMode; static;
/// <param name="version">version in question
/// </param>
/// <returns> number of bits used, in this QR Code symbol {@link Version}, to encode the
/// count of characters that will follow encoded in this {@link Mode}
/// </returns>
function getCharacterCountBits(const version: TVersion): Integer;
/// <summary>
/// Returns a <see cref="System.String"/> that represents this instance.
/// </summary>
/// <returns>
/// A <see cref="System.String"/> that represents this instance.
/// </returns>
function ToString: String; override;
/// <summary>
/// Gets the name.
/// </summary>
property Name: String read Fname;
/// <summary>
/// Gets the bits.
/// </summary>
property Bits: Integer read Fbits;
end;
implementation
{ TMode }
constructor TMode.Create(const characterCountBitsForVersions: TArray<Integer>;
const bits: Integer; const name: String);
begin
Self.characterCountBitsForVersions := characterCountBitsForVersions;
Self.Fbits := bits;
Self.Fname := name
end;
class procedure TMode.InitializeClass;
begin
TMode.TERMINATOR := TMode.Create(TArray<Integer>.Create(0, 0, 0), 0, 'TERMINATOR');
TMode.NUMERIC := TMode.Create(TArray<Integer>.Create(10, 12, 14), 1,
'NUMERIC');
TMode.ALPHANUMERIC := TMode.Create(TArray<Integer>.Create(9, 11, 13), 2,
'ALPHANUMERIC');
TMode.STRUCTURED_APPEND := TMode.Create(TArray<Integer>.Create(0, 0, 0), 3,
'STRUCTURED_APPEND');
TMode.BYTE := TMode.Create(TArray<Integer>.Create(8, $10, $10), 4, 'BYTE');
TMode.ECI := TMode.Create(nil, 7, 'ECI');
TMode.KANJI := TMode.Create(TArray<Integer>.Create(8, 10, 12), 8, 'KANJI');
TMode.FNC1_FIRST_POSITION := TMode.Create(nil, 5, 'FNC1_FIRST_POSITION');
TMode.FNC1_SECOND_POSITION := TMode.Create(nil, 9, 'FNC1_SECOND_POSITION');
TMode.HANZI := TMode.Create(TArray<Integer>.Create(8, 10, 12), 13, 'HANZI')
end;
class procedure TMode.FinalizeClass;
begin
TMode.TERMINATOR.characterCountBitsForVersions := nil;
TMode.NUMERIC.characterCountBitsForVersions := nil;
TMode.ALPHANUMERIC.characterCountBitsForVersions := nil;
TMode.STRUCTURED_APPEND.characterCountBitsForVersions := nil;
TMode.BYTE.characterCountBitsForVersions := nil;
TMode.ECI.characterCountBitsForVersions := nil;
TMode.KANJI.characterCountBitsForVersions := nil;
TMode.FNC1_FIRST_POSITION.characterCountBitsForVersions := nil;
TMode.FNC1_SECOND_POSITION.characterCountBitsForVersions := nil;
TMode.HANZI.characterCountBitsForVersions := nil;
// SetLength(TMode.TERMINATOR.name, 0);
// SetLength(TMode.NUMERIC.name, 0);
// SetLength(TMode.ALPHANUMERIC.name, 0);
// SetLength(TMode.STRUCTURED_APPEND.name, 0);
// SetLength(TMode.BYTE.name, 0);
// SetLength(TMode.ECI.name, 0);
// SetLength(TMode.KANJI.name, 0);
// SetLength(TMode.FNC1_FIRST_POSITION.name, 0);
// SetLength(TMode.FNC1_SECOND_POSITION.name, 0);
// SetLength(TMode.HANZI.name, 0);
FreeAndNil(TMode.TERMINATOR);
FreeAndNil(TMode.NUMERIC);
FreeAndNil(TMode.ALPHANUMERIC);
FreeAndNil(TMode.STRUCTURED_APPEND);
FreeAndNil(TMode.BYTE);
FreeAndNil(TMode.ECI);
FreeAndNil(TMode.KANJI);
FreeAndNil(TMode.FNC1_FIRST_POSITION);
FreeAndNil(TMode.FNC1_SECOND_POSITION);
FreeAndNil(TMode.HANZI);
end;
class function TMode.forBits(const bits: Integer): TMode;
begin
case bits of
$0: Result := TMode.TERMINATOR;
$1: Result := TMode.NUMERIC;
$2: Result := TMode.ALPHANUMERIC;
$3: Result := TMode.STRUCTURED_APPEND;
$4: Result := TMode.BYTE;
$5: Result := TMode.FNC1_FIRST_POSITION;
$7: Result := TMode.ECI;
$8: Result := TMode.KANJI;
$9: Result := TMode.FNC1_SECOND_POSITION;
$D: Result := TMode.HANZI; // 0xD is defined in GBT 18284-2000, may not be supported in foreign country
else
raise EArgumentException.Create('Invalid arguments');
end;
end;
function TMode.getCharacterCountBits(const version: TVersion): Integer;
var
offset,
number : Integer;
begin
if (Self.characterCountBitsForVersions = nil)
then
raise EArgumentException.Create('Character count doesn''t apply to this mode');
number := version.VersionNumber;
if (number <= 9)
then
offset := 0
else
if (number <= 26)
then
offset := 1
else
offset := 2;
Result := Self.characterCountBitsForVersions[offset];
end;
function TMode.ToString: string;
begin
Result := Self.name;
end;
initialization
TMode.InitializeClass;
finalization
TMode.FinalizeClass;
end.
@@ -0,0 +1,77 @@
{
* Copyright 2013 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Delphi Implementation by E. Spelt and K. Gossens
}
unit ZXing.QrCode.Internal.QRCodeDecoderMetaData;
interface
uses
ZXing.ResultPoint;
type
/// <summary>
/// Meta-data container for QR Code decoding. Instances of this class may be used to convey information back to the
/// decoding caller. Callers are expected to process this.
/// </summary>
TQRCodeDecoderMetaData = class sealed
private
Fmirrored: Boolean;
public
/// <summary>
/// Initializes a new instance of the <see cref="TQRCodeDecoderMetaData"/> class.
/// </summary>
/// <param name="mirrored">if set to <c>true</c> [mirrored].</param>
constructor Create(const mirrored: Boolean);
/// <summary>
/// Apply the result points' order correction due to mirroring.
/// </summary>
/// <param name="points">Array of points to apply mirror correction to.</param>
procedure applyMirroredCorrection(const points: TArray<IResultPoint>);
/// <summary>
/// true if the QR Code was mirrored.
/// </summary>
property IsMirrored: boolean read Fmirrored;
end;
implementation
{ TQRCodeDecoderMetaData }
constructor TQRCodeDecoderMetaData.Create(const mirrored: Boolean);
begin
Fmirrored := mirrored;
end;
procedure TQRCodeDecoderMetaData.applyMirroredCorrection(
const points: TArray<IResultPoint>);
var
bottomLeft: IResultPoint;
begin
if ((FMirrored and (points <> nil)) and (Length(points) >= 3)) then
begin
bottomLeft := points[0];
points[0] := points[2];
points[2] := bottomLeft;
// No need to 'fix' top-left and alignment pattern.
end
end;
end.
@@ -0,0 +1,681 @@
{
* Copyright 2007 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Original Author: Sean Owen
* Delphi Implementation by E. Spelt and K. Gossens
}
unit ZXing.QrCode.Internal.Version;
interface
uses
System.SysUtils,
ZXing.Common.Bitmatrix,
ZXing.QrCode.Internal.ErrorCorrectionLevel,
ZXing.QrCode.Internal.FormatInformation,
ZXing.Common.Detector.MathUtils;
type
/// <summary>
/// See ISO 18004:2006 Annex D
/// </summary>
TVersion = class
type
TECB = class
public
count: Integer;
dataCodewords: Integer;
constructor Create(count: Integer; dataCodewords: Integer);
end;
TECBlocks = class sealed
private
ecBlocks: TArray<TECB>;
function getTotalECCodeWords: Integer;
function get_NumBlocks: Integer;
public
ecCodewordsPerBlock: Integer;
constructor Create(ecCodewordsPerBlock: Integer; ecBlocks: TArray<TECB>);
destructor Destroy; override;
function getECBlocks: TArray<TECB>;
{ property ecCodewordsPerBlock: Integer read get_ECCodewordsPerBlock;
property NumBlocks: Integer read get_NumBlocks;
property TotalECCodewords: Integer read get_TotalECCodewords;
}
property NumBlocks: Integer read get_NumBlocks;
property TotalECCodewords: Integer read getTotalECCodeWords;
end;
private
FalignmentPatternCenters: TArray<Integer>;
FecBlocks: TArray<TECBlocks>;
FTotalCodewords: Integer;
FversionNumber: Integer;
class var BuildVersions : TArray<TVersion>;
/// <summary> See ISO 18004:2006 Annex D.
/// Element i represents the raw version bits that specify version i + 7
/// </summary>
class var VERSION_DECODE_INFO: TArray<Integer>;
function CalcDimensionForVersion: Integer;
class function GetBuildVersions: TArray<TVersion>; static;
class procedure ClassInit; static;
class procedure ClassFinal; static;
public
constructor Create(const versionNumber: Integer;
const alignmentPatternCenters: TArray<Integer>;
const ecBlocks: TArray<TECBlocks>);
destructor Destroy; override;
class function decodeVersionInformation(versionBits: Integer)
: TVersion; static;
function buildFunctionPattern: TBitMatrix;
function getECBlocksForLevel(ecLevel: TErrorCorrectionLevel): TECBlocks;
class function getProvisionalVersionForDimension(
const dimension: Integer): TVersion; static;
class function getVersionForNumber(
const versionNumber: Integer): TVersion; static;
function ToString: String; override;
property DimensionForVersion: Integer read CalcDimensionForVersion;
property alignmentPatternCenters: TArray<Integer>
read FalignmentPatternCenters;
property TotalCodewords: Integer read FTotalCodewords;
property versionNumber: Integer read FversionNumber;
end;
implementation
{ TVersion.TECB }
constructor TVersion.TECB.Create(count, dataCodewords: Integer);
begin
self.count := count;
self.dataCodewords := dataCodewords;
end;
{ TVersion.TECBlocks }
constructor TVersion.TECBlocks.Create(ecCodewordsPerBlock: Integer;
ecBlocks: TArray<TECB>);
begin
self.ecBlocks := ecBlocks;
self.ecCodewordsPerBlock := ecCodewordsPerBlock;
end;
destructor TVersion.TECBlocks.Destroy;
begin
ecBlocks :=nil;
inherited;
end;
function TVersion.TECBlocks.getECBlocks: TArray<TECB>;
begin
result := self.ecBlocks;
end;
function TVersion.TECBlocks.getTotalECCodeWords: Integer;
begin
result := ecCodewordsPerBlock * NumBlocks;
end;
function TVersion.TECBlocks.get_NumBlocks: Integer;
var
total: Integer;
ecBlock: TECB;
begin
total := 0;
for ecBlock in ecBlocks do
begin
inc(total, ecBlock.count);
end;
result := total;
end;
{ TVersion }
constructor TVersion.Create(const versionNumber: Integer;
const alignmentPatternCenters: TArray<Integer>;
const ecBlocks: TArray<TECBlocks>);
var
ecBlock: TECB;
total, ecCodewords: Integer;
ecbArray: TArray<TECB>;
begin
FversionNumber := versionNumber;
FalignmentPatternCenters := alignmentPatternCenters;
FecBlocks := ecBlocks;
total := 0;
ecCodewords := ecBlocks[0].ecCodewordsPerBlock;
ecbArray := ecBlocks[0].getECBlocks;
for ecBlock in ecbArray do
Inc(total, (ecBlock.count * (ecBlock.dataCodewords + ecCodewords)));
FTotalCodewords := total;
ecbArray := nil;
end;
destructor TVersion.Destroy;
var
ecBlocks : TECBlocks;
ECB : TECB;
begin
FalignmentPatternCenters := nil;
for ecBlocks in FecBlocks do
begin
for ecb in ecBlocks.ecBlocks do
begin
ECB.Free;
//ECB := nil;
end;
ecBlocks.free;
end;
FecBlocks := nil;
inherited;
end;
function TVersion.buildFunctionPattern: TBitMatrix;
var
dimension, max, x, i, y: Integer;
begin
dimension := DimensionForVersion;
result := TBitMatrix.Create(dimension);
result.setRegion(0, 0, 9, 9);
result.setRegion((dimension - 8), 0, 8, 9);
result.setRegion(0, (dimension - 8), 9, 8);
max := Length(FalignmentPatternCenters);
x := 0;
while ((x < max)) do
begin
i := (FalignmentPatternCenters[x] - 2);
y := 0;
while ((y < max)) do
begin
if (((x <> 0) or ((y <> 0) and (y <> (max - 1)))) and
((x <> (max - 1)) or (y <> 0))) then
result.setRegion((self.alignmentPatternCenters[y] - 2), i, 5, 5);
inc(y)
end;
inc(x)
end;
result.setRegion(6, 9, 1, (dimension - $11));
result.setRegion(9, 6, (dimension - $11), 1);
if (self.versionNumber > 6) then
begin
result.setRegion((dimension - 11), 0, 3, 6);
result.setRegion(0, (dimension - 11), 6, 3)
end;
end;
class function TVersion.GetBuildVersions: TArray<TVersion>;
begin
Result := TArray<TVersion>.Create(
TVersion.Create(1, TArray<Integer>.Create(),
TArray<TECBlocks>.Create(TECBlocks.Create(7,
TArray<TECB>.Create(TECB.Create(1, 19))), TECBlocks.Create(10,
TArray<TECB>.Create(TECB.Create(1, 16))), TECBlocks.Create(13,
TArray<TECB>.Create(TECB.Create(1, 13))), TECBlocks.Create(17,
TArray<TECB>.Create(TECB.Create(1, 9))))),
TVersion.Create(2, TArray<Integer>.Create(6, 18),
TArray<TECBlocks>.Create(TECBlocks.Create(10,
TArray<TECB>.Create(TECB.Create(1, 34))), TECBlocks.Create(16,
TArray<TECB>.Create(TECB.Create(1, 28))), TECBlocks.Create(22,
TArray<TECB>.Create(TECB.Create(1, 22))), TECBlocks.Create(28,
TArray<TECB>.Create(TECB.Create(1, 16))))),
TVersion.Create(3, TArray<Integer>.Create(6, 22),
TArray<TECBlocks>.Create(TECBlocks.Create(15,
TArray<TECB>.Create(TECB.Create(1, 55))), TECBlocks.Create(26,
TArray<TECB>.Create(TECB.Create(1, 44))), TECBlocks.Create(18,
TArray<TECB>.Create(TECB.Create(2, 17))), TECBlocks.Create(22,
TArray<TECB>.Create(TECB.Create(2, 13))))),
TVersion.Create(4, TArray<Integer>.Create(6, 26),
TArray<TECBlocks>.Create(TECBlocks.Create(20,
TArray<TECB>.Create(TECB.Create(1, 80))), TECBlocks.Create(18,
TArray<TECB>.Create(TECB.Create(2, 32))), TECBlocks.Create(26,
TArray<TECB>.Create(TECB.Create(2, 24))), TECBlocks.Create(16,
TArray<TECB>.Create(TECB.Create(4, 9))))),
TVersion.Create(5, TArray<Integer>.Create(6, 30),
TArray<TECBlocks>.Create(TECBlocks.Create(26,
TArray<TECB>.Create(TECB.Create(1, 108))), TECBlocks.Create(24,
TArray<TECB>.Create(TECB.Create(2, 43))), TECBlocks.Create(18,
TArray<TECB>.Create(TECB.Create(2, 15), TECB.Create(2, 16))),
TECBlocks.Create(22, TArray<TECB>.Create(TECB.Create(2, 11),
TECB.Create(2, 12))))),
TVersion.Create(6, TArray<Integer>.Create(6, 34),
TArray<TECBlocks>.Create(TECBlocks.Create(18,
TArray<TECB>.Create(TECB.Create(2, 68))), TECBlocks.Create(16,
TArray<TECB>.Create(TECB.Create(4, 27))), TECBlocks.Create(24,
TArray<TECB>.Create(TECB.Create(4, 19))), TECBlocks.Create(28,
TArray<TECB>.Create(TECB.Create(4, 15))))),
TVersion.Create(7, TArray<Integer>.Create(6, 22, 38),
TArray<TECBlocks>.Create(TECBlocks.Create(20,
TArray<TECB>.Create(TECB.Create(2, 78))), TECBlocks.Create(18,
TArray<TECB>.Create(TECB.Create(4, 31))), TECBlocks.Create(18,
TArray<TECB>.Create(TECB.Create(2, 14), TECB.Create(4, 15))),
TECBlocks.Create(26, TArray<TECB>.Create(TECB.Create(4, 13),
TECB.Create(1, 14))))),
TVersion.Create(8, TArray<Integer>.Create(6, 24, 42),
TArray<TECBlocks>.Create(TECBlocks.Create(24,
TArray<TECB>.Create(TECB.Create(2, 97))), TECBlocks.Create(22,
TArray<TECB>.Create(TECB.Create(2, 38), TECB.Create(2, 39))),
TECBlocks.Create(22, TArray<TECB>.Create(TECB.Create(4, 18), TECB.Create(2,
19))), TECBlocks.Create(26, TArray<TECB>.Create(TECB.Create(4, 14),
TECB.Create(2, 15))))),
TVersion.Create(9, TArray<Integer>.Create(6, 26, 46),
TArray<TECBlocks>.Create(TECBlocks.Create(30,
TArray<TECB>.Create(TECB.Create(2, 116))), TECBlocks.Create(22,
TArray<TECB>.Create(TECB.Create(3, 36), TECB.Create(2, 37))),
TECBlocks.Create(20, TArray<TECB>.Create(TECB.Create(4, 16), TECB.Create(4,
17))), TECBlocks.Create(24, TArray<TECB>.Create(TECB.Create(4, 12),
TECB.Create(4, 13))))),
TVersion.Create(10, TArray<Integer>.Create(6, 28, 50),
TArray<TECBlocks>.Create(TECBlocks.Create(18,
TArray<TECB>.Create(TECB.Create(2, 68), TECB.Create(2, 69))),
TECBlocks.Create(26, TArray<TECB>.Create(TECB.Create(4, 43), TECB.Create(1,
44))), TECBlocks.Create(24, TArray<TECB>.Create(TECB.Create(6, 19),
TECB.Create(2, 20))), TECBlocks.Create(28,
TArray<TECB>.Create(TECB.Create(6, 15), TECB.Create(2, 16))))),
TVersion.Create(11, TArray<Integer>.Create(6, 30, 54),
TArray<TECBlocks>.Create(TECBlocks.Create(20,
TArray<TECB>.Create(TECB.Create(4, 81))), TECBlocks.Create(30,
TArray<TECB>.Create(TECB.Create(1, 50), TECB.Create(4, 51))),
TECBlocks.Create(28, TArray<TECB>.Create(TECB.Create(4, 22), TECB.Create(4,
23))), TECBlocks.Create(24, TArray<TECB>.Create(TECB.Create(3, 12),
TECB.Create(8, 13))))),
TVersion.Create(12, TArray<Integer>.Create(6, 32, 58),
TArray<TECBlocks>.Create(TECBlocks.Create(24,
TArray<TECB>.Create(TECB.Create(2, 92), TECB.Create(2, 93))),
TECBlocks.Create(22, TArray<TECB>.Create(TECB.Create(6, 36), TECB.Create(2,
37))), TECBlocks.Create(26, TArray<TECB>.Create(TECB.Create(4, 20),
TECB.Create(6, 21))), TECBlocks.Create(28,
TArray<TECB>.Create(TECB.Create(7, 14), TECB.Create(4, 15))))),
TVersion.Create(13, TArray<Integer>.Create(6, 34, 62),
TArray<TECBlocks>.Create(TECBlocks.Create(26,
TArray<TECB>.Create(TECB.Create(4, 107))), TECBlocks.Create(22,
TArray<TECB>.Create(TECB.Create(8, 37), TECB.Create(1, 38))),
TECBlocks.Create(24, TArray<TECB>.Create(TECB.Create(8, 20), TECB.Create(4,
21))), TECBlocks.Create(22, TArray<TECB>.Create(TECB.Create(12, 11),
TECB.Create(4, 12))))),
TVersion.Create(14, TArray<Integer>.Create(6, 26, 46, 66),
TArray<TECBlocks>.Create(TECBlocks.Create(30,
TArray<TECB>.Create(TECB.Create(3, 115), TECB.Create(1, 116))),
TECBlocks.Create(24, TArray<TECB>.Create(TECB.Create(4, 40), TECB.Create(5,
41))), TECBlocks.Create(20, TArray<TECB>.Create(TECB.Create(11, 16),
TECB.Create(5, 17))), TECBlocks.Create(24,
TArray<TECB>.Create(TECB.Create(11, 12), TECB.Create(5, 13))))),
TVersion.Create(15, TArray<Integer>.Create(6, 26, 48, 70),
TArray<TECBlocks>.Create(TECBlocks.Create(22,
TArray<TECB>.Create(TECB.Create(5, 87), TECB.Create(1, 88))),
TECBlocks.Create(24, TArray<TECB>.Create(TECB.Create(5, 41), TECB.Create(5,
42))), TECBlocks.Create(30, TArray<TECB>.Create(TECB.Create(5, 24),
TECB.Create(7, 25))), TECBlocks.Create(24,
TArray<TECB>.Create(TECB.Create(11, 12), TECB.Create(7, 13))))),
TVersion.Create(16, TArray<Integer>.Create(6, 26, 50, 74),
TArray<TECBlocks>.Create(TECBlocks.Create(24,
TArray<TECB>.Create(TECB.Create(5, 98), TECB.Create(1, 99))),
TECBlocks.Create(28, TArray<TECB>.Create(TECB.Create(7, 45), TECB.Create(3,
46))), TECBlocks.Create(24, TArray<TECB>.Create(TECB.Create(15, 19),
TECB.Create(2, 20))), TECBlocks.Create(30,
TArray<TECB>.Create(TECB.Create(3, 15), TECB.Create(13, 16))))),
TVersion.Create(17, TArray<Integer>.Create(6, 30, 54, 78),
TArray<TECBlocks>.Create(TECBlocks.Create(28,
TArray<TECB>.Create(TECB.Create(1, 107), TECB.Create(5, 108))),
TECBlocks.Create(28, TArray<TECB>.Create(TECB.Create(10, 46), TECB.Create(1,
47))), TECBlocks.Create(28, TArray<TECB>.Create(TECB.Create(1, 22),
TECB.Create(15, 23))), TECBlocks.Create(28,
TArray<TECB>.Create(TECB.Create(2, 14), TECB.Create(17, 15))))),
TVersion.Create(18, TArray<Integer>.Create(6, 30, 56, 82),
TArray<TECBlocks>.Create(TECBlocks.Create(30,
TArray<TECB>.Create(TECB.Create(5, 120), TECB.Create(1, 121))),
TECBlocks.Create(26, TArray<TECB>.Create(TECB.Create(9, 43), TECB.Create(4,
44))), TECBlocks.Create(28, TArray<TECB>.Create(TECB.Create(17, 22),
TECB.Create(1, 23))), TECBlocks.Create(28,
TArray<TECB>.Create(TECB.Create(2, 14), TECB.Create(19, 15))))),
TVersion.Create(19, TArray<Integer>.Create(6, 30, 58, 86),
TArray<TECBlocks>.Create(TECBlocks.Create(28,
TArray<TECB>.Create(TECB.Create(3, 113), TECB.Create(4, 114))),
TECBlocks.Create(26, TArray<TECB>.Create(TECB.Create(3, 44), TECB.Create(11,
45))), TECBlocks.Create(26, TArray<TECB>.Create(TECB.Create(17, 21),
TECB.Create(4, 22))), TECBlocks.Create(26,
TArray<TECB>.Create(TECB.Create(9, 13), TECB.Create(16, 14))))),
TVersion.Create(20, TArray<Integer>.Create(6, 34, 62, 90),
TArray<TECBlocks>.Create(TECBlocks.Create(28,
TArray<TECB>.Create(TECB.Create(3, 107), TECB.Create(5, 108))),
TECBlocks.Create(26, TArray<TECB>.Create(TECB.Create(3, 41), TECB.Create(13,
42))), TECBlocks.Create(30, TArray<TECB>.Create(TECB.Create(15, 24),
TECB.Create(5, 25))), TECBlocks.Create(28,
TArray<TECB>.Create(TECB.Create(15, 15), TECB.Create(10, 16))))),
TVersion.Create(21, TArray<Integer>.Create(6, 28, 50, 72, 94),
TArray<TECBlocks>.Create(TECBlocks.Create(28,
TArray<TECB>.Create(TECB.Create(4, 116), TECB.Create(4, 117))),
TECBlocks.Create(26, TArray<TECB>.Create(TECB.Create(17, 42))),
TECBlocks.Create(28, TArray<TECB>.Create(TECB.Create(17, 22), TECB.Create(6,
23))), TECBlocks.Create(30, TArray<TECB>.Create(TECB.Create(19, 16),
TECB.Create(6, 17))))),
TVersion.Create(22, TArray<Integer>.Create(6, 26, 50, 74, 98),
TArray<TECBlocks>.Create(TECBlocks.Create(28,
TArray<TECB>.Create(TECB.Create(2, 111), TECB.Create(7, 112))),
TECBlocks.Create(28, TArray<TECB>.Create(TECB.Create(17, 46))),
TECBlocks.Create(30, TArray<TECB>.Create(TECB.Create(7, 24), TECB.Create(16,
25))), TECBlocks.Create(24, TArray<TECB>.Create(TECB.Create(34, 13))))),
TVersion.Create(23, TArray<Integer>.Create(6, 30, 54, 78, 102),
TArray<TECBlocks>.Create(TECBlocks.Create(30,
TArray<TECB>.Create(TECB.Create(4, 121), TECB.Create(5, 122))),
TECBlocks.Create(28, TArray<TECB>.Create(TECB.Create(4, 47), TECB.Create(14,
48))), TECBlocks.Create(30, TArray<TECB>.Create(TECB.Create(11, 24),
TECB.Create(14, 25))), TECBlocks.Create(30,
TArray<TECB>.Create(TECB.Create(16, 15), TECB.Create(14, 16))))),
TVersion.Create(24, TArray<Integer>.Create(6, 28, 54, 80, 106),
TArray<TECBlocks>.Create(TECBlocks.Create(30,
TArray<TECB>.Create(TECB.Create(6, 117), TECB.Create(4, 118))),
TECBlocks.Create(28, TArray<TECB>.Create(TECB.Create(6, 45), TECB.Create(14,
46))), TECBlocks.Create(30, TArray<TECB>.Create(TECB.Create(11, 24),
TECB.Create(16, 25))), TECBlocks.Create(30,
TArray<TECB>.Create(TECB.Create(30, 16), TECB.Create(2, 17))))),
TVersion.Create(25, TArray<Integer>.Create(6, 32, 58, 84, 110),
TArray<TECBlocks>.Create(TECBlocks.Create(26,
TArray<TECB>.Create(TECB.Create(8, 106), TECB.Create(4, 107))),
TECBlocks.Create(28, TArray<TECB>.Create(TECB.Create(8, 47), TECB.Create(13,
48))), TECBlocks.Create(30, TArray<TECB>.Create(TECB.Create(7, 24),
TECB.Create(22, 25))), TECBlocks.Create(30,
TArray<TECB>.Create(TECB.Create(22, 15), TECB.Create(13, 16))))),
TVersion.Create(26, TArray<Integer>.Create(6, 30, 58, 86, 114),
TArray<TECBlocks>.Create(TECBlocks.Create(28,
TArray<TECB>.Create(TECB.Create(10, 114), TECB.Create(2, 115))),
TECBlocks.Create(28, TArray<TECB>.Create(TECB.Create(19, 46), TECB.Create(4,
47))), TECBlocks.Create(28, TArray<TECB>.Create(TECB.Create(28, 22),
TECB.Create(6, 23))), TECBlocks.Create(30,
TArray<TECB>.Create(TECB.Create(33, 16), TECB.Create(4, 17))))),
TVersion.Create(27, TArray<Integer>.Create(6, 34, 62, 90, 118),
TArray<TECBlocks>.Create(TECBlocks.Create(30,
TArray<TECB>.Create(TECB.Create(8, 122), TECB.Create(4, 123))),
TECBlocks.Create(28, TArray<TECB>.Create(TECB.Create(22, 45), TECB.Create(3,
46))), TECBlocks.Create(30, TArray<TECB>.Create(TECB.Create(8, 23),
TECB.Create(26, 24))), TECBlocks.Create(30,
TArray<TECB>.Create(TECB.Create(12, 15), TECB.Create(28, 16))))),
TVersion.Create(28, TArray<Integer>.Create(6, 26, 50, 74, 98, 122),
TArray<TECBlocks>.Create(TECBlocks.Create(30,
TArray<TECB>.Create(TECB.Create(3, 117), TECB.Create(10, 118))),
TECBlocks.Create(28, TArray<TECB>.Create(TECB.Create(3, 45), TECB.Create(23,
46))), TECBlocks.Create(30, TArray<TECB>.Create(TECB.Create(4, 24),
TECB.Create(31, 25))), TECBlocks.Create(30,
TArray<TECB>.Create(TECB.Create(11, 15), TECB.Create(31, 16))))),
TVersion.Create(29, TArray<Integer>.Create(6, 30, 54, 78, 102, 126),
TArray<TECBlocks>.Create(TECBlocks.Create(30,
TArray<TECB>.Create(TECB.Create(7, 116), TECB.Create(7, 117))),
TECBlocks.Create(28, TArray<TECB>.Create(TECB.Create(21, 45), TECB.Create(7,
46))), TECBlocks.Create(30, TArray<TECB>.Create(TECB.Create(1, 23),
TECB.Create(37, 24))), TECBlocks.Create(30,
TArray<TECB>.Create(TECB.Create(19, 15), TECB.Create(26, 16))))),
TVersion.Create(30, TArray<Integer>.Create(6, 26, 52, 78, 104, 130),
TArray<TECBlocks>.Create(TECBlocks.Create(30,
TArray<TECB>.Create(TECB.Create(5, 115), TECB.Create(10, 116))),
TECBlocks.Create(28, TArray<TECB>.Create(TECB.Create(19, 47),
TECB.Create(10, 48))), TECBlocks.Create(30,
TArray<TECB>.Create(TECB.Create(15, 24), TECB.Create(25, 25))),
TECBlocks.Create(30, TArray<TECB>.Create(TECB.Create(23, 15),
TECB.Create(25, 16))))),
TVersion.Create(31, TArray<Integer>.Create(6, 30, 56, 82, 108, 134),
TArray<TECBlocks>.Create(TECBlocks.Create(30,
TArray<TECB>.Create(TECB.Create(13, 115), TECB.Create(3, 116))),
TECBlocks.Create(28, TArray<TECB>.Create(TECB.Create(2, 46), TECB.Create(29,
47))), TECBlocks.Create(30, TArray<TECB>.Create(TECB.Create(42, 24),
TECB.Create(1, 25))), TECBlocks.Create(30,
TArray<TECB>.Create(TECB.Create(23, 15), TECB.Create(28, 16))))),
TVersion.Create(32, TArray<Integer>.Create(6, 34, 60, 86, 112, 138),
TArray<TECBlocks>.Create(TECBlocks.Create(30,
TArray<TECB>.Create(TECB.Create(17, 115))), TECBlocks.Create(28,
TArray<TECB>.Create(TECB.Create(10, 46), TECB.Create(23, 47))),
TECBlocks.Create(30, TArray<TECB>.Create(TECB.Create(10, 24),
TECB.Create(35, 25))), TECBlocks.Create(30,
TArray<TECB>.Create(TECB.Create(19, 15), TECB.Create(35, 16))))),
TVersion.Create(33, TArray<Integer>.Create(6, 30, 58, 86, 114, 142),
TArray<TECBlocks>.Create(TECBlocks.Create(30,
TArray<TECB>.Create(TECB.Create(17, 115), TECB.Create(1, 116))),
TECBlocks.Create(28, TArray<TECB>.Create(TECB.Create(14, 46),
TECB.Create(21, 47))), TECBlocks.Create(30,
TArray<TECB>.Create(TECB.Create(29, 24), TECB.Create(19, 25))),
TECBlocks.Create(30, TArray<TECB>.Create(TECB.Create(11, 15),
TECB.Create(46, 16))))),
TVersion.Create(34, TArray<Integer>.Create(6, 34, 62, 90, 118, 146),
TArray<TECBlocks>.Create(TECBlocks.Create(30,
TArray<TECB>.Create(TECB.Create(13, 115), TECB.Create(6, 116))),
TECBlocks.Create(28, TArray<TECB>.Create(TECB.Create(14, 46),
TECB.Create(23, 47))), TECBlocks.Create(30,
TArray<TECB>.Create(TECB.Create(44, 24), TECB.Create(7, 25))),
TECBlocks.Create(30, TArray<TECB>.Create(TECB.Create(59, 16),
TECB.Create(1, 17))))),
TVersion.Create(35, TArray<Integer>.Create(6, 30, 54, 78, 102, 126, 150),
TArray<TECBlocks>.Create(TECBlocks.Create(30,
TArray<TECB>.Create(TECB.Create(12, 121), TECB.Create(7, 122))),
TECBlocks.Create(28, TArray<TECB>.Create(TECB.Create(12, 47),
TECB.Create(26, 48))), TECBlocks.Create(30,
TArray<TECB>.Create(TECB.Create(39, 24), TECB.Create(14, 25))),
TECBlocks.Create(30, TArray<TECB>.Create(TECB.Create(22, 15),
TECB.Create(41, 16))))),
TVersion.Create(36, TArray<Integer>.Create(6, 24, 50, 76, 102, 128, 154),
TArray<TECBlocks>.Create(TECBlocks.Create(30,
TArray<TECB>.Create(TECB.Create(6, 121), TECB.Create(14, 122))),
TECBlocks.Create(28, TArray<TECB>.Create(TECB.Create(6, 47), TECB.Create(34,
48))), TECBlocks.Create(30, TArray<TECB>.Create(TECB.Create(46, 24),
TECB.Create(10, 25))), TECBlocks.Create(30,
TArray<TECB>.Create(TECB.Create(2, 15), TECB.Create(64, 16))))),
TVersion.Create(37, TArray<Integer>.Create(6, 28, 54, 80, 106, 132, 158),
TArray<TECBlocks>.Create(TECBlocks.Create(30,
TArray<TECB>.Create(TECB.Create(17, 122), TECB.Create(4, 123))),
TECBlocks.Create(28, TArray<TECB>.Create(TECB.Create(29, 46),
TECB.Create(14, 47))), TECBlocks.Create(30,
TArray<TECB>.Create(TECB.Create(49, 24), TECB.Create(10, 25))),
TECBlocks.Create(30, TArray<TECB>.Create(TECB.Create(24, 15),
TECB.Create(46, 16))))),
TVersion.Create(38, TArray<Integer>.Create(6, 32, 58, 84, 110, 136, 162),
TArray<TECBlocks>.Create(TECBlocks.Create(30,
TArray<TECB>.Create(TECB.Create(4, 122), TECB.Create(18, 123))),
TECBlocks.Create(28, TArray<TECB>.Create(TECB.Create(13, 46),
TECB.Create(32, 47))), TECBlocks.Create(30,
TArray<TECB>.Create(TECB.Create(48, 24), TECB.Create(14, 25))),
TECBlocks.Create(30, TArray<TECB>.Create(TECB.Create(42, 15),
TECB.Create(32, 16))))),
TVersion.Create(39, TArray<Integer>.Create(6, 26, 54, 82, 110, 138, 166),
TArray<TECBlocks>.Create(TECBlocks.Create(30,
TArray<TECB>.Create(TECB.Create(20, 117), TECB.Create(4, 118))),
TECBlocks.Create(28, TArray<TECB>.Create(TECB.Create(40, 47), TECB.Create(7,
48))), TECBlocks.Create(30, TArray<TECB>.Create(TECB.Create(43, 24),
TECB.Create(22, 25))), TECBlocks.Create(30,
TArray<TECB>.Create(TECB.Create(10, 15), TECB.Create(67, 16))))),
TVersion.Create(40, TArray<Integer>.Create(6, 30, 58, 86, 114, 142, 170),
TArray<TECBlocks>.Create(TECBlocks.Create(30,
TArray<TECB>.Create(TECB.Create(19, 118), TECB.Create(6, 119))),
TECBlocks.Create(28, TArray<TECB>.Create(TECB.Create(18, 47),
TECB.Create(31, 48))), TECBlocks.Create(30,
TArray<TECB>.Create(TECB.Create(34, 24), TECB.Create(34, 25))),
TECBlocks.Create(30, TArray<TECB>.Create(TECB.Create(20, 15),
TECB.Create(61, 16)))))
);
end;
function TVersion.CalcDimensionForVersion: Integer;
begin
result := 17 + 4 * versionNumber;
end;
class function TVersion.decodeVersionInformation(versionBits: Integer)
: TVersion;
var
bestDifference, bestversion, i, targetVersion, bitsDifference: Integer;
begin
bestDifference := $7FFFFFFF;
bestversion := 0;
i := 0;
while ((i < Length(TVersion.VERSION_DECODE_INFO))) do
begin
targetVersion := TVersion.VERSION_DECODE_INFO[i];
if (targetVersion = versionBits) then
begin
result := TVersion.getVersionForNumber((i + 7));
exit
end;
bitsDifference := TFormatInformation.numBitsDiffering(versionBits,
targetVersion);
if (bitsDifference < bestDifference) then
begin
bestversion := (i + 7);
bestDifference := bitsDifference
end;
inc(i)
end;
if (bestDifference <= 3) then
begin
result := TVersion.getVersionForNumber(bestversion);
exit
end;
result := nil;
end;
function TVersion.getECBlocksForLevel(ecLevel: TErrorCorrectionLevel)
: TECBlocks;
begin
result := FecBlocks[ecLevel.ordinal]
end;
class function TVersion.getProvisionalVersionForDimension(
const dimension: Integer): TVersion;
begin
Result := nil;
if ((dimension mod 4) <> 1)
then
exit;
try
Result := TVersion.getVersionForNumber(TMathUtils.Asr(dimension - $11, 2));
except
on E: EArgumentException do
Result := nil;
end
end;
class function TVersion.getVersionForNumber(
const versionNumber: Integer): TVersion;
begin
if ((versionNumber < 1) or (versionNumber > 40)) then
raise EArgumentException.Create
('version number needs to be between 1 and 40');
Result := TVersion.BuildVersions[(versionNumber - 1)];
end;
function TVersion.ToString: string;
begin
result := self.versionNumber.ToString();
end;
class procedure TVersion.ClassInit();
begin
TVersion.VERSION_DECODE_INFO := TArray<Integer>.Create($7C94, $85BC, $9A99,
$A4D3, $BBF6, $C762, $D847, $E60D, $F928, $10B78, $1145D, $12A17, $13532,
$149A6, $15683, $168C9, $177EC, $18EC4, $191E1, $1AFAB, $1B08E, $1CC1A,
$1D33F, $1ED75, $1F250, $209D5, $216F0, $228BA, $2379F, $24B0B, $2542E,
$26A64, $27541, $28C69);
TVersion.BuildVersions := TVersion.GetBuildVersions;
end;
class procedure TVersion.ClassFinal();
var version :Tversion;
begin
TVersion.VERSION_DECODE_INFO := nil;
for version in TVersion.BuildVersions do
begin
version.Free;
end;
TVersion.BuildVersions :=nil;
end;
Initialization
TVersion.ClassInit();
Finalization
TVersion.ClassFinal();
end.
@@ -0,0 +1,632 @@
{
* Copyright 2008 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Original Author: Sean Owen
* Delphi Implementation by K. Gossens
}
unit ZXing.Datamatrix.Internal.Detector;
interface
uses
System.SysUtils,
System.Math,
System.Generics.Defaults,
System.Generics.Collections,
ZXing.Common.BitMatrix,
ZXing.DefaultGridSampler,
ZXing.Common.DetectorResult,
ZXing.ResultPoint,
ZXing.Common.GridSampler,
ZXing.Common.Detector.MathUtils,
ZXing.Common.Detector.WhiteRectangleDetector;
type
/// <summary>
/// <p>Encapsulates logic that can detect a Data Matrix Code in an image, even if the Data Matrix Code
/// is rotated or skewed, or partially obscured.</p>
/// </summary>
TDataMatrixDetector = class(TObject)
private
var
Fimage: TBitMatrix;
FrectangleDetector: TWhiteRectangleDetector;
type
/// <summary>
/// Simply encapsulates two points and a number of transitions between them.
/// </summary>
TResultPointsAndTransitions = class sealed
public
From: IResultPoint;
To_: IResultPoint;
Transitions: Integer;
constructor Create(From: IResultPoint; To_: IResultPoint;
Transitions: Integer);
destructor Destroy; override;
function ToString: String; override;
end;
/// <summary>
/// Orders ResultPointsAndTransitions by number of transitions, ascending.
/// </summary>
TResultPointsAndTransitionsComparator = class sealed
(TComparer<TResultPointsAndTransitions>)
public
function Compare(const o1, o2: TResultPointsAndTransitions)
: Integer; override;
end;
var
FtransCompare: TResultPointsAndTransitionsComparator;
public
constructor Create(const image: TBitMatrix);
destructor Destroy; override;
function detect: TDetectorResult;
function transitionsBetween(Afrom, Ato: IResultPoint)
: TResultPointsAndTransitions;
function distance(a: IResultPoint; b: IResultPoint): Integer;
procedure increment(table: TDictionary<IResultPoint, Integer>;
key: IResultPoint);
function sampleGrid(image: TBitMatrix; topLeft, bottomLeft, bottomRight,
topRight: IResultPoint; dimensionX, dimensionY: Integer): TBitMatrix;
function isValid(p: IResultPoint): Boolean;
function correctTopRight(bottomLeft, bottomRight, topLeft,
topRight: IResultPoint; dimension: Integer): IResultPoint;
function correctTopRightRectangular(bottomLeft, bottomRight, topLeft,
topRight: IResultPoint; dimensionTop, dimensionRight: Integer)
: IResultPoint;
end;
implementation
{ TDataMatrixDetector }
/// <summary>
/// Initializes a new instance of the <see cref="Detector"/> class.
/// </summary>
/// <param name="image">The image.</param>
constructor TDataMatrixDetector.Create(const image: TBitMatrix);
begin
Self.Fimage := image;
Self.FrectangleDetector := TWhiteRectangleDetector.New(image);
Self.FtransCompare := TResultPointsAndTransitionsComparator.Create;
end;
destructor TDataMatrixDetector.Destroy;
begin
if (FrectangleDetector <> nil) then
FrectangleDetector.Free;
FtransCompare.Free;
inherited;
end;
/// <summary>
/// <p>Detects a Data Matrix Code in an image.</p>
/// </summary>
/// <returns><see cref="DetectorResult" />encapsulating results of detecting a Data Matrix Code or null</returns>
function TDataMatrixDetector.detect(): TDetectorResult;
var
topRight, correctedTopRight, pointA, pointB, pointC, pointD, maybeTopLeft,
bottomLeft, bottomRight, topLeft, maybeBottomRight, point: IResultPoint;
cornerPoints: TArray<IResultPoint>;
bits: TBitMatrix;
entry: TPair<IResultPoint, Integer>; // TKeyValuePair
Transitions: TObjectList<TResultPointsAndTransitions>;
lSideOne, lSideTwo, transBetween, transA, transB: TResultPointsAndTransitions;
pointCount: TDictionary<IResultPoint, Integer>;
corners: TArray<IResultPoint>;
dimensionTop, dimensionRight, dimension, dimensionCorrected: Integer;
begin
Result := nil;
if (FrectangleDetector = nil) then
// can be null, if the image is to small
exit;
cornerPoints := FrectangleDetector.detect();
if (cornerPoints = nil) then
exit;
pointA := cornerPoints[0];
pointB := cornerPoints[1];
pointC := cornerPoints[2];
pointD := cornerPoints[3];
// Point A and D are across the diagonal from one another,
// as are B and C. Figure out which are the solid black lines
// by counting transitions
Transitions := TObjectList<TResultPointsAndTransitions>.Create;
pointCount := TDictionary<IResultPoint, Integer>.Create();
try
Transitions.Add(transitionsBetween(pointA, pointB));
Transitions.Add(transitionsBetween(pointA, pointC));
Transitions.Add(transitionsBetween(pointB, pointD));
Transitions.Add(transitionsBetween(pointC, pointD));
Transitions.Sort(FtransCompare);
// Sort by number of transitions. First two will be the two solid sides; last two
// will be the two alternating black/white sides
lSideOne := Transitions[0];
lSideTwo := Transitions[1];
// Figure out which point is their intersection by tallying up the number of times we see the
// endpoints in the four endpoints. One will show up twice.
increment(pointCount, lSideOne.From);
increment(pointCount, lSideOne.To_);
increment(pointCount, lSideTwo.From);
increment(pointCount, lSideTwo.To_);
maybeTopLeft := nil;
bottomLeft := nil;
maybeBottomRight := nil;
for entry in pointCount do
begin
point := entry.key;
if (entry.Value = 2) then
bottomLeft := point
// this is definitely the bottom left, then -- end of two L sides
else
begin
// Otherwise it's either top left or bottom right -- just assign the two arbitrarily now
if (maybeTopLeft = nil) then
maybeTopLeft := point
else
maybeBottomRight := point;
end;
end;
if ((maybeTopLeft = nil) or (bottomLeft = nil) or (maybeBottomRight = nil))
then
exit;
// Bottom left is correct but top left and bottom right might be switched
corners := TArray<IResultPoint>.Create(maybeTopLeft, bottomLeft,
maybeBottomRight);
// Use the dot product trick to sort them out
TResultPointHelpers.orderBestPatterns(corners);
// Now we know which is which:
bottomRight := corners[0];
bottomLeft := corners[1];
topLeft := corners[2];
// Which point didn't we find in relation to the "L" sides? that's the top right corner
if (not pointCount.ContainsKey(pointA)) then
topRight := pointA
else if (not pointCount.ContainsKey(pointB)) then
topRight := pointB
else if (not pointCount.ContainsKey(pointC)) then
topRight := pointC
else
topRight := pointD;
// Next determine the dimension by tracing along the top or right side and counting black/white
// transitions. Since we start inside a black module, we should see a number of transitions
// equal to 1 less than the code dimension. Well, actually 2 less, because we are going to
// end on a black module:
// The top right point is actually the corner of a module, which is one of the two black modules
// adjacent to the white module at the top right. Tracing to that corner from either the top left
// or bottom right should work here.
transBetween := transitionsBetween(topLeft, topRight);
dimensionTop := transBetween.Transitions;
transBetween.Free;
transBetween := transitionsBetween(bottomRight, topRight);
dimensionRight := transBetween.Transitions;
transBetween.Free;
if ((dimensionTop and $01) = 1) then
// it can't be odd, so, round... up?
Inc(dimensionTop);
Inc(dimensionTop, 2);
if ((dimensionRight and $01) = 1) then
// it can't be odd, so, round... up?
Inc(dimensionRight);
Inc(dimensionRight, 2);
// Rectangular symbols are 6x16, 6x28, 10x24, 10x32, 14x32, or 14x44. If one dimension is more
// than twice the other, it's certainly rectangular, but to cut a bit more slack we accept it as
// rectangular if the bigger side is at least 7/4 times the other:
if (((4 * dimensionTop) >= (7 * dimensionRight)) or
((4 * dimensionRight) >= (7 * dimensionTop))) then
begin
// The matrix is rectangular
correctedTopRight := correctTopRightRectangular(bottomLeft, bottomRight,
topLeft, topRight, dimensionTop, dimensionRight);
if (correctedTopRight = nil) then
correctedTopRight := topRight;
transBetween := transitionsBetween(topLeft, correctedTopRight);
dimensionTop := transBetween.Transitions;
transBetween.Free;
transBetween := transitionsBetween(bottomRight, correctedTopRight);
dimensionRight := transBetween.Transitions;
transBetween.Free;
if ((dimensionTop and $01) = 1) then
// it can't be odd, so, round... up?
Inc(dimensionTop);
if ((dimensionRight and $01) = 1) then
// it can't be odd, so, round... up?
Inc(dimensionRight);
bits := sampleGrid(Fimage, topLeft, bottomLeft, bottomRight,
correctedTopRight, dimensionTop, dimensionRight)
end
else
begin
// The matrix is square
dimension := System.Math.Min(dimensionRight, dimensionTop);
// correct top right point to match the white module
correctedTopRight := correctTopRight(bottomLeft, bottomRight, topLeft,
topRight, dimension);
if (correctedTopRight = nil) then
correctedTopRight := topRight;
// Redetermine the dimension using the corrected top right point
transA := transitionsBetween(topLeft, correctedTopRight);
transB := transitionsBetween(bottomRight, correctedTopRight);
dimensionCorrected :=
(System.Math.Max(transA.Transitions, transB.Transitions) + 1);
transA.Free;
transB.Free;
if ((dimensionCorrected and $01) = 1) then
Inc(dimensionCorrected);
bits := sampleGrid(Fimage, topLeft, bottomLeft, bottomRight,
correctedTopRight, dimensionCorrected, dimensionCorrected);
end;
if (bits = nil) then
exit;
Result := TDetectorResult.Create(bits, TArray<IResultPoint>.Create(topLeft,
bottomLeft, bottomRight, correctedTopRight));
finally
pointCount.Free;
Transitions.Free;
cornerPoints := nil;
end;
end;
/// <summary>
/// Calculates the position of the white top right module using the output of the rectangle detector
/// for a rectangular matrix
/// </summary>
function TDataMatrixDetector.correctTopRightRectangular(bottomLeft, bottomRight,
topLeft, topRight: IResultPoint; dimensionTop, dimensionRight: Integer)
: IResultPoint;
var
corr, norm, cos, sin: Single;
c1, c2: IResultPoint;
l1, l2: Integer;
rpT1, rpT2: TResultPointsAndTransitions;
begin
corr := (distance(bottomLeft, bottomRight) / dimensionTop);
norm := distance(topLeft, topRight);
if (norm = 0) then
begin
Result := nil;
exit
end;
cos := ((topRight.X - topLeft.X) / norm);
sin := ((topRight.Y - topLeft.Y) / norm);
c1 := TResultPointHelpers.CreateResultPoint((topRight.X + (corr * cos)),
(topRight.Y + (corr * sin)));
corr := (distance(bottomLeft, topLeft) / dimensionRight);
norm := distance(bottomRight, topRight);
if (norm = 0) then
begin
Result := nil;
exit;
end;
cos := ((topRight.X - bottomRight.X) / norm);
sin := ((topRight.Y - bottomRight.Y) / norm);
c2 := TResultPointHelpers.CreateResultPoint((topRight.X + (corr * cos)),
(topRight.Y + (corr * sin)));
if (not isValid(c1)) then
begin
if (isValid(c2)) then
begin
Result := c2;
exit;
end;
Result := nil;
exit;
end;
if (not isValid(c2)) then
begin
Result := c1;
exit;
end;
rpT1 := transitionsBetween(topLeft, c1);
rpT2 := transitionsBetween(bottomRight, c1);
l1 := (Abs((dimensionTop - rpT1.Transitions)) +
Abs((dimensionRight - rpT2.Transitions)));
FreeAndNil(rpT1);
FreeAndNil(rpT2);
rpT1 := transitionsBetween(topLeft, c2);
rpT2 := transitionsBetween(bottomRight, c2);
l2 := (Abs((dimensionTop - rpT1.Transitions)) +
Abs((dimensionRight - rpT2.Transitions)));
FreeAndNil(rpT1);
FreeAndNil(rpT2);
if (l1 <= l2) then
begin
Result := c1;
end
else
begin
Result := c2;
end;
end;
/// <summary>
/// Calculates the position of the white top right module using the output of the rectangle detector
/// for a square matrix
/// </summary>
function TDataMatrixDetector.correctTopRight(bottomLeft, bottomRight, topLeft,
topRight: IResultPoint; dimension: Integer): IResultPoint;
var
corr, cos, sin: Single;
norm: Integer;
c1, c2: IResultPoint;
l1, l2: Integer;
transA, transB: TResultPointsAndTransitions;
begin
corr := (distance(bottomLeft, bottomRight) / dimension);
norm := distance(topLeft, topRight);
if (norm = 0) then
begin
Result := nil;
exit;
end;
cos := ((topRight.X - topLeft.X) / norm);
sin := ((topRight.Y - topLeft.Y) / norm);
c1 := TResultPointHelpers.CreateResultPoint((topRight.X + (corr * cos)),
(topRight.Y + (corr * sin)));
corr := (distance(bottomLeft, topLeft) / dimension);
norm := distance(bottomRight, topRight);
if (norm = 0) then
begin
Result := nil;
exit;
end;
cos := ((topRight.X - bottomRight.X) / norm);
sin := ((topRight.Y - bottomRight.Y) / norm);
c2 := TResultPointHelpers.CreateResultPoint((topRight.X + (corr * cos)),
(topRight.Y + (corr * sin)));
if (not isValid(c1)) then
begin
if (isValid(c2)) then
begin
Result := c2;
exit;
end;
Result := nil;
exit;
end;
if (not isValid(c2)) then
begin
Result := c1;
exit;
end;
transA := transitionsBetween(topLeft, c1);
transB := transitionsBetween(bottomRight, c1);
l1 := (Abs(transA.Transitions - transB.Transitions));
transA.Free;
transB.Free;
transA := transitionsBetween(topLeft, c2);
transB := transitionsBetween(bottomRight, c2);
l2 := (Abs(transA.Transitions - transB.Transitions));
transA.Free;
transB.Free;
if (l1 <= l2) then
begin
Result := c1;
end
else
begin
Result := c2;
end;
end;
function TDataMatrixDetector.isValid(p: IResultPoint): Boolean;
begin
Result := ((((p.X >= 0) and (p.X < Fimage.Width)) and (p.Y > 0)) and
(p.Y < Fimage.Height))
end;
// L2 distance
function TDataMatrixDetector.distance(a: IResultPoint; b: IResultPoint)
: Integer;
begin
Result := TMathUtils.round(TResultPointHelpers.distance(a, b))
end;
/// <summary>
/// Increments the Integer associated with a key by one.
/// </summary>
procedure TDataMatrixDetector.increment
(table: TDictionary<IResultPoint, Integer>; key: IResultPoint);
var
Value: Integer;
begin
if (table.ContainsKey(key)) then
begin
Value := table[key];
table[key] := (Value + 1);
end
else
table.Add(key, 1); // table[key] := 1;
end;
function TDataMatrixDetector.sampleGrid(image: TBitMatrix;
topLeft, bottomLeft, bottomRight, topRight: IResultPoint;
dimensionX, dimensionY: Integer): TBitMatrix;
begin
// TGridSampler.instance
Result := TDefaultGridSampler.sampleGrid(image, dimensionX, dimensionY, 0.5,
0.5, (dimensionX - 0.5), 0.5, (dimensionX - 0.5), (dimensionY - 0.5), 0.5,
(dimensionY - 0.5), topLeft.X, topLeft.Y, topRight.X, topRight.Y,
bottomRight.X, bottomRight.Y, bottomLeft.X, bottomLeft.Y);
end;
/// <summary>
/// Counts the number of black/white transitions between two points, using something like Bresenham's algorithm.
/// </summary>
function TDataMatrixDetector.transitionsBetween(Afrom, Ato: IResultPoint)
: TResultPointsAndTransitions;
var
temp, fromX, fromY, toX, toY: Integer;
steep: Boolean;
dx, dy: Int64;
xstep, ystep, Transitions: Integer;
error: Int64;
inBlack, isBlack: Boolean;
X, Y: Integer;
begin
// See QR Code Detector, sizeOfBlackWhiteBlackRun()
fromX := Trunc(Afrom.X);
fromY := Trunc(Afrom.Y);
toX := Trunc(Ato.X);
toY := Trunc(Ato.Y);
steep := (Abs((toY - fromY)) > Abs((toX - fromX)));
if (steep) then
begin
temp := fromX;
fromX := fromY;
fromY := temp;
temp := toX;
toX := toY;
toY := temp;
end;
dx := Abs(toX - fromX);
dy := Abs(toY - fromY);
error := TMathUtils.Asr(-dx, 1);
if (fromY < toY) then
ystep := 1
else
ystep := -1;
if (fromX < toX) then
xstep := 1
else
xstep := -1;
Transitions := 0;
if steep then
inBlack := Fimage[fromY, fromX]
else
inBlack := Fimage[fromX, fromY];
X := fromX;
Y := fromY;
while ((X <> toX)) do
begin
if steep then
isBlack := Fimage[Y, X]
else
isBlack := Fimage[X, Y];
if (isBlack <> inBlack) then
begin
Inc(Transitions);
inBlack := isBlack;
end;
Inc(error, dy);
if (error > 0) then
begin
if (Y = toY) then
break;
Inc(Y, ystep);
Dec(error, dx);
end;
Inc(X, xstep)
end;
Result := TResultPointsAndTransitions.Create(Afrom, Ato, Transitions);
end;
{ TResultPointsAndTransitions }
constructor TDataMatrixDetector.TResultPointsAndTransitions.Create
(From: IResultPoint; To_: IResultPoint; Transitions: Integer);
begin
Self.From := From;
Self.To_ := To_;
Self.Transitions := Transitions;
end;
destructor TDataMatrixDetector.TResultPointsAndTransitions.Destroy;
begin
// if (Assigned(Self.From)) then
// Self.From := nil;
//
// if (Assigned(Self.To_)) then
// Self.To_:=nil;
inherited;
end;
function TDataMatrixDetector.TResultPointsAndTransitions.ToString: string;
begin
Result := From.ToString + '/' + To_.ToString + '/' + IntToStr(Transitions);
end;
function TDataMatrixDetector.TResultPointsAndTransitionsComparator.Compare
(const o1, o2: TResultPointsAndTransitions): Integer;
begin
Result := (o1.Transitions - o2.Transitions);
end;
end.
@@ -0,0 +1,69 @@
{
* Copyright 2007 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Original Author: Sean Owen
* Ported from ZXING Java Source: www.Redivivus.in (suraj.supekar@redivivus.in)
* Delphi Implementation by E.Spelt and K. Gossens
}
unit ZXing.QrCode.Internal.AlignmentPattern;
interface
uses ZXing.ResultPoint;
type
/// <summary>
/// As we did for ResultPoint, we use an interfaced object to implement automatic deallocation
/// of TAligmnentPattern instances
/// the actual implementation of this interface is in unit ZXing.QrCode.Internal.AlignmentPatternImplementation
/// </summary>
IAlignmentPattern = interface(IResultPoint)
['{8C0A5D01-9620-42B6-BE3E-9C40717B5B38}']
/// <summary> <p>Determines if this alignment pattern "about equals" an alignment pattern at the stated
/// position and size -- meaning, it is at nearly the same center with nearly the same size.</p>
/// </summary>
function aboutEquals(const moduleSize, i, j: Single): Boolean;
/// <summary>
/// Combines this object's current estimate of a finder pattern position and module size
/// with a new estimate. It returns a new {@code FinderPattern} containing an average of the two.
/// </summary>
/// <param name="i">The i.</param>
/// <param name="j">The j.</param>
/// <param name="newModuleSize">New size of the module.</param>
/// <returns></returns>
function combineEstimate(const i, j, newModuleSize: Single): IAlignmentPattern;
end;
/// <summary>
/// contains all static methods for using IAlignmentPatterns instances
/// </summary>
TAlignmentPatternHelpers = class
/// <summary>
/// IAlignmentPattern instances must be obtained by calling this function
/// </summary>
class function CreateAlignmentPattern(const posX, posY, estimatedModuleSize: Single):IAlignmentPattern;
end;
implementation
uses ZXing.QrCode.Internal.AlignmentPatternImplementation;
{ TAlignmentPatternHelpers }
class function TAlignmentPatternHelpers.CreateAlignmentPattern(const posX, posY, estimatedModuleSize: Single):IAlignmentPattern;
begin
result := ZXing.QrCode.Internal.AlignmentPatternImplementation.NewAlignmentPattern(posX,posY,estimatedModuleSize);
end;
end.
@@ -0,0 +1,407 @@
{
* Copyright 2007 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Original Author: Sean Owen
* Ported from ZXING Java Source: www.Redivivus.in (suraj.supekar@redivivus.in)
* Delphi Implementation by E.Spelt and K. Gossens
}
unit ZXing.QrCode.Internal.AlignmentPatternFinder;
interface
uses
System.SysUtils,
System.Math,
System.Generics.Collections,
ZXing.Common.BitMatrix,
ZXing.QrCode.Internal.AlignmentPattern, // nullableType,
ZXing.ResultPoint,
ZXing.Common.Detector.MathUtils;
type
/// <summary> <p>This class attempts to find alignment patterns in a QR Code. Alignment patterns look like finder
/// patterns but are smaller and appear at regular intervals throughout the image.</p>
///
/// <p>At the moment this only looks for the bottom-right alignment pattern.</p>
///
/// <p>This is mostly a simplified copy of {@link FinderPatternFinder}. It is copied,
/// pasted and stripped down here for maximum performance but does unfortunately duplicate
/// some code.</p>
///
/// <p>This class is thread-safe but not reentrant. Each thread must allocate its own object.</p>
///
/// </summary>
TAlignmentPatternFinder = class sealed
private
image: TBitMatrix;
possibleCenters: TList<IAlignmentPattern>;
startX, startY: Integer;
width, height: Integer;
moduleSize: Single;
crossCheckStateCount: TArray<Integer>;
resultPointCallback: TResultPointCallback;
/// <summary> Given a count of black/white/black pixels just seen and an end position,
/// figures the location of the center of this black/white/black run.
/// </summary>
class function centerFromEnd(const stateCount: TArray<Integer>;
const pEnd: Integer): Single; static;
/// <param name="stateCount">count of black/white/black pixels just read
/// </param>
/// <returns> true iff the proportions of the counts is close enough to the 1/1/1 ratios
/// used by alignment patterns to be considered a match
/// </returns>
function foundPatternCross(const stateCount: TArray<Integer>): Boolean;
/// <summary>
/// <p>After a horizontal scan finds a potential alignment pattern, this method
/// "cross-checks" by scanning down vertically through the center of the possible
/// alignment pattern to see if the same proportion is detected.</p>
/// </summary>
/// <param name="startI">row where an alignment pattern was detected</param>
/// <param name="centerJ">center of the section that appears to cross an alignment pattern</param>
/// <param name="maxCount">maximum reasonable number of modules that should be
/// observed in any reading state, based on the results of the horizontal scan</param>
/// <param name="originalStateCountTotal">The original state count total.</param>
/// <returns>
/// vertical center of alignment pattern, or null if not found
/// </returns>
function crossCheckVertical(const startI, centerJ, maxCount,
originalStateCountTotal: Integer): Single;
/// <summary> <p>This is called when a horizontal scan finds a possible alignment pattern. It will
/// cross check with a vertical scan, and if successful, will see if this pattern had been
/// found on a previous horizontal scan. If so, we consider it confirmed and conclude we have
/// found the alignment pattern.</p>
///
/// </summary>
/// <param name="stateCount">reading state module counts from horizontal scan
/// </param>
/// <param name="i">row where alignment pattern may be found
/// </param>
/// <param name="j">end of possible alignment pattern in row
/// </param>
/// <returns> {@link TAlignmentPattern} if we have found the same pattern twice, or null if not
/// </returns>
function handlePossibleCenter(const stateCount: TArray<Integer>;
const i, j: Integer): IAlignmentPattern;
public
/// <summary> <p>Creates a finder that will look in a portion of the whole image.</p>
///
/// </summary>
/// <param name="image">image to search
/// </param>
/// <param name="startX">left column from which to start searching
/// </param>
/// <param name="startY">top row from which to start searching
/// </param>
/// <param name="width">width of region to search
/// </param>
/// <param name="height">height of region to search
/// </param>
/// <param name="moduleSize">estimated module size so far
/// </param>
constructor Create(const image: TBitMatrix; const startX, startY,
width, height: Integer; const moduleSize: Single;
resultPointCallback: TResultPointCallback);
destructor Destroy; override;
/// <summary> <p>This method attempts to find the bottom-right alignment pattern in the image. It is a bit messy since
/// it's pretty performance-critical and so is written to be fast foremost.</p>
///
/// </summary>
/// <returns> {@link TAlignmentPattern} if found
/// </returns>
function find: IAlignmentPattern;
end;
implementation
{ TAlignmentPatternFinder }
constructor TAlignmentPatternFinder.Create(const image: TBitMatrix;
const startX, startY, width, height: Integer; const moduleSize: Single;
resultPointCallback: TResultPointCallback);
begin
Self.image := image;
Self.possibleCenters := TList<IAlignmentPattern>.Create;
Self.possibleCenters.Capacity := 5;
Self.startX := startX;
Self.startY := startY;
Self.width := width;
Self.height := height;
Self.moduleSize := moduleSize;
Self.crossCheckStateCount := TArray<Integer>.Create(0, 0, 0);
Self.resultPointCallback := resultPointCallback;
end;
destructor TAlignmentPatternFinder.Destroy;
begin
if possibleCenters<>nil then
possibleCenters.Clear;
FreeAndNil(self.possibleCenters);
self.crossCheckStateCount := nil;
self.resultPointCallback :=nil;
inherited;
end;
function TAlignmentPatternFinder.find: IAlignmentPattern;
var
confirmed: IAlignmentPattern;
maxJ, middleI, iGen, i, j, currentState: Integer;
stateCount: TArray<Integer>;
begin
startX := Self.startX;
height := Self.height;
maxJ := startX + self.width;
middleI := Self.startY + (TMathUtils.Asr(height, 1));
// We are looking for black/white/black modules in 1:1:1 ratio;
// this tracks the number of black/white/black modules seen so far
stateCount := TArray<Integer>.Create(0, 0, 0);
for iGen := 0 to Pred(height) do
begin
// Search from middle outwards
if ((iGen and 1) = 0)
then
i := middleI + (TMathUtils.Asr(iGen + 1, 1))
else
i := middleI + (-1 * TMathUtils.Asr(iGen + 1, 1));
stateCount[0] := 0;
stateCount[1] := 0;
stateCount[2] := 0;
j := startX;
// Burn off leading white pixels before anything else; if we start in the middle of
// a white run, it doesn't make sense to count its length, since we don't know if the
// white run continued to the left of the start point
while ((j < maxJ) and (not Self.image[j, i])) do
Inc(j);
currentState := 0;
while ((j < maxJ)) do
begin
if (Self.image[j, i]) then
begin
// Black pixel
if (currentState = 1) then
begin
// Counting black pixels
Inc(stateCount[currentState]);
end else
begin
// Counting white pixels
if (currentState = 2) then
begin
// A winner?
if (Self.foundPatternCross(stateCount)) then
begin
// Yes
confirmed := self.handlePossibleCenter(stateCount, i, j);
if (confirmed <> nil) then
begin
result := confirmed;
exit
end;
end;
stateCount[0] := stateCount[2];
stateCount[1] := 1;
stateCount[2] := 0;
currentState := 1;
end else
begin
Inc(currentState);
Inc(stateCount[currentState]);
end;
end;
end else
begin
// White pixel
if (currentState = 1)
then
// Counting black pixels
Inc(currentState);
Inc(stateCount[currentState])
end;
Inc(j)
end;
if (Self.foundPatternCross(stateCount)) then
begin
confirmed := self.handlePossibleCenter(stateCount, i, maxJ);
if (confirmed <> nil) then
begin
result := confirmed;
exit;
end;
end;
end;
// Hmm, nothing we saw was observed and confirmed twice. If we had
// any guess at all, return it.
if (Self.possibleCenters.Count <> 0)
then
Result := Self.possibleCenters[0]
else
Result := nil;
end;
class function TAlignmentPatternFinder.centerFromEnd(
const stateCount: TArray<Integer>; const pEnd: Integer): Single;
begin
Result := (pEnd - stateCount[2]) - (stateCount[1] / 2.0);
if (Single.IsNaN(Result))
then
Result := -1;
end;
function TAlignmentPatternFinder.foundPatternCross(
const stateCount: TArray<Integer>): Boolean;
var
maxVariance: Single;
i: Integer;
begin
maxVariance := moduleSize / 2;
for i := 0 to Pred(3) do
begin
if (Abs(self.moduleSize - stateCount[i]) >= maxVariance) then
begin
Result := false;
exit;
end;
end;
Result := true;
end;
function TAlignmentPatternFinder.crossCheckVertical(const startI, centerJ,
maxCount, originalStateCountTotal: Integer): Single;
var
maxI,
i, stateCountTotal: Integer;
stateCount: TArray<Integer>;
begin
maxI := Self.image.height;
stateCount := Self.crossCheckStateCount;
stateCount[0] := 0;
stateCount[1] := 0;
stateCount[2] := 0;
// Start counting up from center
i := startI;
while (((i >= 0) and self.image[centerJ, i]) and
(stateCount[1] <= maxCount)) do
begin
Inc(stateCount[1]);
Dec(i);
end;
// If already too many modules in this state or ran off the edge:
if ((i < 0) or (stateCount[1] > maxCount)) then
begin
Result := -1;
exit;
end;
while (((i >= 0) and (not Self.image[centerJ, i])) and
(stateCount[0] <= maxCount)) do
begin
Inc(stateCount[0]);
Dec(i);
end;
if (stateCount[0] > maxCount) then
begin
Result := -1;
exit;
end;
// Now also count down from center
i := (startI + 1);
while (((i < maxI) and Self.image[centerJ, i]) and
(stateCount[1] <= maxCount)) do
begin
Inc(stateCount[1]);
Inc(i);
end;
if ((i = maxI) or (stateCount[1] > maxCount)) then
begin
Result := -1;
exit;
end;
while (((i < maxI) and not self.image[centerJ, i]) and
(stateCount[2] <= maxCount)) do
begin
Inc(stateCount[2]);
Inc(i);
end;
if (stateCount[2] > maxCount) then
begin
Result := -1;
exit;
end;
stateCountTotal := (stateCount[0] + stateCount[1] + stateCount[2]);
if ((5 * Abs(stateCountTotal - originalStateCountTotal)) >=
(2 * originalStateCountTotal)) then
begin
Result := -1;
exit;
end;
if Self.foundPatternCross(stateCount)
then
Result := TAlignmentPatternFinder.centerFromEnd(stateCount, i)
else
Result := -1;
end;
function TAlignmentPatternFinder.handlePossibleCenter(
const stateCount: TArray<Integer>; const i, j: Integer): IAlignmentPattern;
var
center, point: IAlignmentPattern;
stateCountTotal: Integer;
estimatedModuleSize: Single;
centerJ, centerI: Single;
begin
stateCountTotal := (stateCount[0] + stateCount[1] + stateCount[2]);
centerJ := TAlignmentPatternFinder.centerFromEnd(stateCount, j);
if (centerJ = -1) then
begin
Result := nil;
exit;
end;
centerI := crossCheckVertical(i, Floor(centerJ), (2 * stateCount[1]),
stateCountTotal);
if (centerI <> -1) then
begin
estimatedModuleSize := (stateCount[0] + stateCount[1] + stateCount[2]) / 3.0;
for center in Self.possibleCenters do
begin
// Look for about the same center and module size:
if (center.aboutEquals(estimatedModuleSize, centerI, centerJ)) then
begin
Result := center.combineEstimate(centerI, centerJ, estimatedModuleSize);
exit;
end;
end;
// Hadn't found this before; save it
point := TAlignmentPatternHelpers.CreateAlignmentPattern(centerJ, centerI, estimatedModuleSize);
Self.possibleCenters.Add(point);
if Assigned(resultPointCallback)
then
Self.resultPointCallback(point);
end;
Result := nil;
end;
end.
@@ -0,0 +1,112 @@
{
* Copyright 2007 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Original Author: Sean Owen
* Ported from ZXING Java Source: www.Redivivus.in (suraj.supekar@redivivus.in)
* Delphi Implementation by E.Spelt and K. Gossens
}
unit ZXing.QrCode.Internal.AlignmentPatternImplementation;
interface
uses
ZXing.QrCode.Internal.AlignmentPattern,
ZXing.ResultPoint,
ZXing.ResultPointImplementation;
// this is the function that actually creates IAlignmentPattern instances.
// the actual implementation of the interface is totally hidden to all other units,
// since even its declaration is in the implementation section of this unit
function NewAlignmentPattern(const posX, posY, estimatedModuleSize: Single):IAlignmentPattern;
implementation
{ TAlignmentPattern }
type
/// <summary> <p>Encapsulates an alignment pattern, which are the smaller square patterns found in
/// all but the simplest QR Codes.</p>
///
/// </summary>
TAlignmentPattern = class sealed(TResultPoint,IResultPoint,IAlignmentPattern)
private
estimatedModuleSize: Single;
constructor Create(const posX, posY, estimatedModuleSize: Single);
/// <summary> <p>Determines if this alignment pattern "about equals" an alignment pattern at the stated
/// position and size -- meaning, it is at nearly the same center with nearly the same size.</p>
/// </summary>
function aboutEquals(const moduleSize, i, j: Single): Boolean;
/// <summary>
/// Combines this object's current estimate of a finder pattern position and module size
/// with a new estimate. It returns a new {@code FinderPattern} containing an average of the two.
/// </summary>
/// <param name="i">The i.</param>
/// <param name="j">The j.</param>
/// <param name="newModuleSize">New size of the module.</param>
/// <returns></returns>
function combineEstimate(const i, j,
newModuleSize: Single): IAlignmentPattern;
end;
constructor TAlignmentPattern.Create(const posX, posY,
estimatedModuleSize: Single);
begin
inherited Create(posX, posY);
Self.estimatedModuleSize := estimatedModuleSize;
end;
function TAlignmentPattern.aboutEquals(const moduleSize, i, j: Single): Boolean;
var
moduleSizeDiff: Single;
begin
if ((Abs(i - Self.y) <= moduleSize) and
(Abs(j - Self.x) <= moduleSize)) then
begin
moduleSizeDiff := Abs(moduleSize - self.estimatedModuleSize);
Result := ((moduleSizeDiff <= 1) or
(moduleSizeDiff <= self.estimatedModuleSize));
end else Result := false;
end;
function TAlignmentPattern.combineEstimate(const i, j,
newModuleSize: Single): IAlignmentPattern;
var
combinedX,
combinedY,
combinedModuleSize : Single;
begin
combinedX := (self.x + j) / 2.0;
combinedY := (self.y + i) / 2.0;
combinedModuleSize := (estimatedModuleSize + newModuleSize) / 2.0;
Result := TAlignmentPattern.Create(combinedX, combinedY, combinedModuleSize);
end;
function NewAlignmentPattern(const posX, posY, estimatedModuleSize: Single):IAlignmentPattern;
begin
result := TAlignmentPattern.Create(posX,posY,estimatedModuleSize);
end;
end.
@@ -0,0 +1,492 @@
{
* Copyright 2007 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Original Author: Sean Owen
* Delphi Implementation by E. Spelt and K. Gossens
}
unit ZXing.QrCode.Internal.Detector;
interface
uses
System.SysUtils,
System.Math,
Generics.Collections,
ZXing.Common.BitMatrix,
ZXing.ResultPoint,
ZXing.Common.DetectorResult,
ZXing.DecodeHintType,
ZXing.Common.PerspectiveTransform,
ZXing.QrCode.Internal.FinderPatternInfo,
ZXing.QrCode.Internal.FinderPatternFinder,
ZXing.QrCode.Internal.FinderPattern,
ZXing.QrCode.Internal.AlignmentPattern,
ZXing.QrCode.Internal.AlignmentPatternFinder,
ZXing.QrCode.Internal.Version,
ZXing.DefaultGridSampler,
ZXing.Common.Detector.MathUtils;
type
/// <summary>
/// <p>Encapsulates logic that can detect a QR Code in an image, even if the QR Code
/// is rotated or skewed, or partially obscured.</p>
/// </summary>
TDetector = class
private
FImage: TBitMatrix;
FResultPointCallback: TResultPointCallback;
function calculateModuleSizeOneWay(pattern: IResultpoint;
otherPattern: IResultpoint): Single;
class function computeDimension(topLeft: IResultpoint;
topRight: IResultpoint; bottomLeft: IResultpoint; moduleSize: Single;
var dimension: Integer): boolean; static;
class function createTransform(const topLeft, topRight, bottomLeft,
AlignmentPattern: IResultpoint; const dimension: Integer)
: TPerspectiveTransform; static;
class function sampleGrid(image: TBitMatrix;
transform: TPerspectiveTransform; dimension: Integer): TBitMatrix; static;
function sizeOfBlackWhiteBlackRun(fromX: Integer; fromY: Integer;
toX: Integer; toY: Integer): Single;
function sizeOfBlackWhiteBlackRunBothWays(fromX: Integer; fromY: Integer;
toX: Integer; toY: Integer): Single;
protected
function calculateModuleSize(const topLeft, topRight,
bottomLeft: IResultPoint): Single; virtual;
function findAlignmentInRegion(const overallEstModuleSize: Single;
const estAlignmentX, estAlignmentY: Integer;
const allowanceFactor: Single): IAlignmentPattern;
/// <summary>
/// Processes the finder pattern info.
/// </summary>
/// <param name="info">The info.</param>
/// <returns></returns>
function processFinderPatternInfo(const info: TFinderPatternInfo)
: TDetectorResult; virtual;
public
/// <summary>
/// Initializes a new instance of the <see cref="Detector"/> class.
/// </summary>
/// <param name="image">The image.</param>
constructor Create(const image: TBitMatrix);
destructor Destroy; override;
/// <summary>
/// <p>Detects a QR Code in an image.</p>
/// </summary>
/// <returns>
/// <see cref="TDetectorResult"/> encapsulating results of detecting a QR Code
/// </returns>
function detect(): TDetectorResult; overload;
/// <summary>
/// <p>Detects a QR Code in an image.</p>
/// </summary>
/// <param name="hints">optional hints to detector</param>
/// <returns>
/// <see cref="TDetectorResult"/> encapsulating results of detecting a QR Code
/// </returns>
function detect(const hints: TDictionary<TDecodeHintType, TObject>)
: TDetectorResult; overload;
property image: TBitMatrix read FImage;
property ResultPointCallback: TResultPointCallback
read FResultPointCallback;
end;
implementation
{ TDetector }
constructor TDetector.Create(const image: TBitMatrix);
begin
FImage := image;
end;
destructor TDetector.Destroy;
begin
FResultPointCallback := nil;
inherited;
end;
function TDetector.calculateModuleSize(const topLeft, topRight,
bottomLeft: IResultPoint): Single;
begin
Result := ((self.calculateModuleSizeOneWay(topLeft, topRight) +
self.calculateModuleSizeOneWay(topLeft, bottomLeft)) / 2)
end;
function TDetector.calculateModuleSizeOneWay(pattern: IResultPoint;
otherPattern: IResultPoint): Single;
var
moduleSizeEst1, moduleSizeEst2: Single;
begin
moduleSizeEst1 := self.sizeOfBlackWhiteBlackRunBothWays(Floor(pattern.X),
Floor(pattern.Y), Floor(otherPattern.X), Floor(otherPattern.Y));
moduleSizeEst2 := self.sizeOfBlackWhiteBlackRunBothWays(Floor(otherPattern.X),
Floor(otherPattern.Y), Floor(pattern.X), Floor(pattern.Y));
if (moduleSizeEst1 = -1) then
begin
Result := (moduleSizeEst2 / 7);
exit
end;
if (moduleSizeEst2 = -1) then
begin
Result := (moduleSizeEst1 / 7);
exit
end;
Result := ((moduleSizeEst1 + moduleSizeEst2) / 14);
end;
class function TDetector.computeDimension(topLeft: IResultPoint;
topRight: IResultPoint; bottomLeft: IResultPoint; moduleSize: Single;
var dimension: Integer): boolean;
var
tltrCentersDimension, tlblCentersDimension: Integer;
begin
tltrCentersDimension :=
round((TResultPointHelpers.distance(topLeft, topRight) / moduleSize));
tlblCentersDimension :=
round((TResultPointHelpers.distance(topLeft, bottomLeft) / moduleSize));
dimension := TMathUtils.Asr
((tltrCentersDimension + tlblCentersDimension), 1) + 7;
case (dimension and 3) of
0: inc(dimension); // below a valid dimension
1: ; // exactly on a valid dimension e.g. 21, 25, 29, ..., 177
2: dec(dimension); // above a valid dimension
3: Exit(False); // exactly between two valid dimensions
end;
Result := True;
end;
class function TDetector.createTransform(const topLeft, topRight, bottomLeft,
AlignmentPattern: IResultPoint; const dimension: Integer)
: TPerspectiveTransform;
var
bottomRightX, bottomRightY, sourceBottomRightX, sourceBottomRightY,
dimMinusThree: Single;
begin
dimMinusThree := (dimension - 3.5);
if (AlignmentPattern <> nil) then
begin
bottomRightX := AlignmentPattern.X;
bottomRightY := AlignmentPattern.Y;
sourceBottomRightX := (dimMinusThree - 3);
sourceBottomRightY := sourceBottomRightX;
end
else
begin
bottomRightX := ((topRight.X - topLeft.X) + bottomLeft.X);
bottomRightY := ((topRight.Y - topLeft.Y) + bottomLeft.Y);
sourceBottomRightX := dimMinusThree;
sourceBottomRightY := sourceBottomRightX;
end;
Result := TPerspectiveTransform.quadrilateralToQuadrilateral(3.5, 3.5,
dimMinusThree, 3.5, sourceBottomRightX, sourceBottomRightY, 3.5,
dimMinusThree, topLeft.X, topLeft.Y, topRight.X, topRight.Y, bottomRightX,
bottomRightY, bottomLeft.X, bottomLeft.Y);
end;
function TDetector.detect: TDetectorResult;
begin
Result := self.detect(nil)
end;
function TDetector.detect(const hints: TDictionary<TDecodeHintType, TObject>)
: TDetectorResult;
var
obj: TObject;
info: TFinderPatternInfo;
finder: TFinderPatternFinder;
begin
Result := nil;
if ((hints = nil) or
(not hints.ContainsKey(TDecodeHintType.NEED_RESULT_POINT_CALLBACK))) then
FResultPointCallback := nil
else
begin
obj := hints[TDecodeHintType.NEED_RESULT_POINT_CALLBACK];
if (obj is TResultPointEventObject) then
FResultPointCallback := TResultPointEventObject(obj).Event;
end;
finder := TFinderPatternFinder.Create(FImage, ResultPointCallback);
try
info := finder.find(hints);
if Assigned(info) then
begin
Result := processFinderPatternInfo(info);
info.Free;
end;
finally
finder.Free;
end;
end;
function TDetector.processFinderPatternInfo(const info: TFinderPatternInfo)
: TDetectorResult;
var
topLeft, topRight, bottomLeft: IFinderPattern;
moduleSize, bottomRightX, bottomRightY, correctionToTopLeft: Single;
dimension, i, modulesBetweenFPCenters, estAlignmentX, estAlignmentY: Integer;
points: TArray<IResultPoint>;
provisionalVersion: TVersion;
transform: TPerspectiveTransform;
bits: TBitMatrix;
AlignmentPattern: IAlignmentPattern;
begin
Result := nil;
topLeft := info.topLeft;
topRight := info.topRight;
bottomLeft := info.bottomLeft;
moduleSize := calculateModuleSize(topLeft, topRight, bottomLeft);
if (moduleSize < 1.0) then
exit;
if (not TDetector.computeDimension(topLeft, topRight, bottomLeft, moduleSize,
dimension)) then
exit;
provisionalVersion := TVersion.getProvisionalVersionForDimension(dimension);
if (provisionalVersion = nil) then
exit;
modulesBetweenFPCenters := (provisionalVersion.DimensionForVersion - 7);
AlignmentPattern := nil;
// Anything above version 1 has an alignment pattern
if (Length(provisionalVersion.AlignmentPatternCenters) > 0) then
begin
// Guess where a "bottom right" finder pattern would have been
bottomRightX := (topRight.X - topLeft.X) + bottomLeft.X;
bottomRightY := (topRight.Y - topLeft.Y) + bottomLeft.Y;
// Estimate that alignment pattern is closer by 3 modules
// from "bottom right" to known top left location
correctionToTopLeft := (1.0 - (3.0 / modulesBetweenFPCenters));
estAlignmentX :=
Floor(topLeft.X + (correctionToTopLeft * (bottomRightX - topLeft.X)));
estAlignmentY :=
Floor(topLeft.Y + (correctionToTopLeft * (bottomRightY - topLeft.Y)));
i := 4;
while ((i <= 16)) do
begin
AlignmentPattern := findAlignmentInRegion(moduleSize, estAlignmentX,
estAlignmentY, i);
if (AlignmentPattern <> nil) then
break;
i := (i shl 1);
end;
// If we didn't find alignment pattern... well try anyway without it
end;
transform := TDetector.createTransform(topLeft, topRight, bottomLeft,
AlignmentPattern, dimension);
try
bits := TDetector.sampleGrid(FImage, transform, dimension);
finally
transform.Free;
end;
if (bits = nil) then
exit;
if (AlignmentPattern = nil) then
points := TArray<IResultPoint>.Create(bottomLeft, topLeft, topRight)
else
points := TArray<IResultPoint>.Create(bottomLeft, topLeft, topRight,
AlignmentPattern);
Result := TDetectorResult.Create(bits, points);
end;
function TDetector.findAlignmentInRegion(const overallEstModuleSize: Single;
const estAlignmentX, estAlignmentY: Integer; const allowanceFactor: Single)
: IAlignmentPattern;
var
allowance, alignmentAreaRightX, alignmentAreaLeftX, alignmentAreaTopY,
alignmentAreaBottomY: Integer;
alignmentFinder: TAlignmentPatternFinder;
candidateResult: IAlignmentPattern;
begin
Result := nil;
allowance := Floor(allowanceFactor * overallEstModuleSize);
alignmentAreaLeftX := System.Math.Max(0, (estAlignmentX - allowance));
alignmentAreaRightX := System.Math.Min((FImage.Width - 1),
(estAlignmentX + allowance));
if ((alignmentAreaRightX - alignmentAreaLeftX) < (overallEstModuleSize * 3))
then
exit;
alignmentAreaTopY := System.Math.Max(0, (estAlignmentY - allowance));
alignmentAreaBottomY := System.Math.Min((FImage.Height - 1),
(estAlignmentY + allowance));
alignmentFinder := TAlignmentPatternFinder.Create(FImage, alignmentAreaLeftX,
alignmentAreaTopY, (alignmentAreaRightX - alignmentAreaLeftX),
(alignmentAreaBottomY - alignmentAreaTopY), overallEstModuleSize,
self.ResultPointCallback);
candidateResult := alignmentFinder.find;
if candidateResult = nil then
Result := nil
else
Result := candidateResult;
FreeAndNil(alignmentFinder);
end;
class function TDetector.sampleGrid(image: TBitMatrix;
transform: TPerspectiveTransform; dimension: Integer): TBitMatrix;
begin
Result := TDefaultGridSampler.sampleGrid(image, dimension, dimension,
transform)
end;
function TDetector.sizeOfBlackWhiteBlackRun(fromX: Integer; fromY: Integer;
toX: Integer; toY: Integer): Single;
var
steep: boolean;
temp, dx, dy, xstep, ystep, X, Y, state, xlimit, realx, realy, error: Integer;
begin
steep := Abs(toY - fromY) > Abs(toX - fromX);
if (steep) then
begin
temp := fromX;
fromX := fromY;
fromY := temp;
temp := toX;
toX := toY;
toY := temp
end;
dx := Abs(toX - fromX);
dy := Abs(toY - fromY);
error := TMathUtils.Asr(-dx, 1);
if (fromX < toX) then
xstep := 1
else
xstep := -1;
if (fromY < toY) then
ystep := 1
else
ystep := -1;
state := 0;
xlimit := (toX + xstep);
X := fromX;
Y := fromY;
while ((X <> xlimit)) do
begin
if steep then
realx := Y
else
realx := X;
if steep then
realy := X
else
realy := Y;
if ((state = 1) = FImage[realx, realy]) then
begin
if (state = 2) then
begin
Result := TMathUtils.distance(X, Y, fromX, fromY);
exit
end;
inc(state)
end;
inc(error, dy);
if (error > 0) then
begin
if (Y = toY) then
break;;
inc(Y, ystep);
dec(error, dx)
end;
inc(X, xstep)
end;
if (state = 2) then
begin
Result := TMathUtils.distance((toX + xstep), toY, fromX, fromY);
exit
end;
Result := Single.NaN;
end;
function TDetector.sizeOfBlackWhiteBlackRunBothWays(fromX: Integer;
fromY: Integer; toX: Integer; toY: Integer): Single;
var
scale: Double;
otherToX, otherToY: Integer;
begin
Result := sizeOfBlackWhiteBlackRun(fromX, fromY, toX, toY);
scale := 1;
otherToX := (fromX - (toX - fromX));
if (otherToX < 0) then
begin
scale := (fromX / (fromX - otherToX));
otherToX := 0
end
else if (otherToX >= FImage.Width) then
begin
scale := (((FImage.Width - 1) - fromX) / (otherToX - fromX));
otherToX := (FImage.Width - 1)
end;
otherToY := Round(fromY - ((toY - fromY) * scale));
scale := 1;
if (otherToY < 0) then
begin
scale := fromY / (fromY - otherToY);
otherToY := 0
end
else if (otherToY >= FImage.Height) then
begin
scale := (((FImage.Height - 1) - fromY) / (otherToY - fromY));
otherToY := (FImage.Height - 1)
end;
otherToX := Round(fromX + (otherToX - fromX) * scale);
Result := Result + self.sizeOfBlackWhiteBlackRun(fromX, fromY, otherToX,
otherToY);
Result := (Result - 1);
end;
end.
@@ -0,0 +1,147 @@
{
* Copyright 2007 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Original Author: Sean Owen
* Delphi Implementation by E. Spelt and K. Gossens
}
unit ZXing.QrCode.Internal.FinderPattern;
interface
uses
ZXing.ResultPoint;
type
/// <summary>
/// As we did for ResultPoint, we use an interfaced object to implement automatic deallocation
/// of TAligmnentPattern instances
/// the actual implementation of this interface is in unit ZXing.QrCode.Internal.FinderPatternImplementation
/// </summary>
IFinderPattern = interface(IResultPoint)
['{EF95BB2F-8863-4A83-840E-699779592EC0}']
function GetCount:integer;
procedure SetCount(value:integer);
/// <summary> <p>Determines if this finder pattern "about equals" a finder pattern at the stated
/// position and size -- meaning, it is at nearly the same center with nearly the same size.</p>
/// </summary>
function aboutEquals(const moduleSize, i, j: Single): Boolean;
/// <summary>
/// Combines this object's current estimate of a finder pattern position and module size
/// with a new estimate. It returns a new {@code FinderPattern} containing a weighted average
/// based on count.
/// </summary>
/// <param name="i">The i.</param>
/// <param name="j">The j.</param>
/// <param name="newModuleSize">New size of the module.</param>
/// <returns></returns>
function combineEstimate(const i, j, newModuleSize: Single): IFinderPattern;
/// <summary>
/// Gets the size of the estimated module.
/// </summary>
/// <value>
/// The size of the estimated module.
/// </value>
function estimatedModuleSize : Single;
property count : Integer read GetCount write SetCount;
end;
/// <summary>
/// contains all static methods for using IFinderPattern instances
/// </summary>
TFinderPatternHelpers= class(TResultPointHelpers)
class function CreateFinderPattern(const posX, posY, estimatedModuleSize: Single;
const count: Integer):IFinderPattern; overload;
class function CreateFinderPattern(const posX, posY, estimatedModuleSize: Single):IFinderPattern; overload;
class procedure orderBestPatterns(const patterns: TArray<IFinderPattern>); static;
end;
implementation
uses ZXing.QrCode.Internal.FinderPatternImplementation;
class function TFinderPatternHelpers.CreateFinderPattern(const posX, posY, estimatedModuleSize: Single; const count: Integer):IFinderPattern;
begin
result := ZXing.QrCode.Internal.FinderPatternImplementation.NewFinderPattern(posX, posY, estimatedModuleSize ,count);
end;
class function TFinderPatternHelpers.CreateFinderPattern(const posX, posY, estimatedModuleSize: Single):IFinderPattern;
begin
result := ZXing.QrCode.Internal.FinderPatternImplementation.NewFinderPattern(posX, posY, estimatedModuleSize);
end;
class procedure TFinderPatternHelpers.orderBestPatterns( const patterns: TArray<IFinderPattern>);
var
zeroOneDistance,
oneTwoDistance,
zeroTwoDistance: Single;
pointA,
pointB,
pointC,
temp: IFinderPattern;
begin
// Find distances between pattern centers
zeroOneDistance := distance(patterns[0], patterns[1]);
oneTwoDistance := distance(patterns[1], patterns[2]);
zeroTwoDistance := distance(patterns[0], patterns[2]);
// Assume one closest to other two is B; A and C will just be guesses at first
if ((oneTwoDistance >= zeroOneDistance) and
(oneTwoDistance >= zeroTwoDistance)) then
begin
pointB := patterns[0];
pointA := patterns[1];
pointC := patterns[2];
end
else if ((zeroTwoDistance >= oneTwoDistance) and
(zeroTwoDistance >= zeroOneDistance)) then
begin
pointB := patterns[1];
pointA := patterns[0];
pointC := patterns[2];
end
else
begin
pointB := patterns[2];
pointA := patterns[0];
pointC := patterns[1];
end;
// Use cross product to figure out whether A and C are correct or flipped.
// This asks whether BC x BA has a positive z component, which is the arrangement
// we want for A, B, C. If it's negative, then we've got it flipped around and
// should swap A and C.
if (TResultPointHelpers.crossProductZ(pointA, pointB, pointC) < 0) then
begin
temp := pointA;
pointA := pointC;
pointC := temp;
end;
patterns[0] := pointA;
patterns[1] := pointB;
patterns[2] := pointC;
end;
end.
@@ -0,0 +1,977 @@
{
* Copyright 2007 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Original Author: Sean Owen
* Delphi Implementation by E. Spelt and K. Gossens
}
unit ZXing.QrCode.Internal.FinderPatternFinder;
interface
uses
System.SysUtils,
System.Math,
System.Generics.Defaults,
System.Generics.Collections,
ZXing.Common.BitMatrix,
ZXing.ResultPoint,
ZXing.DecodeHinttype,
ZXing.QrCode.Internal.FinderPatternInfo,
ZXing.QrCode.Internal.FinderPattern;
type
/// <summary>
/// <p>This class attempts to find finder patterns in a QR Code. Finder patterns are the square
/// markers at three corners of a QR Code.</p>
///
/// <p>This class is thread-safe but not reentrant. Each thread must allocate its own object.
/// </summary>
TFinderPatternFinder = class
private
const
CENTER_QUORUM: Integer = 2;
INTEGER_MATH_SHIFT: Integer = 8;
var
FImage: TBitMatrix;
FPossibleCenters: TList<IFinderPattern>;
FhasSkipped: Boolean;
FCrossCheckStateCount: TArray<Integer>;
FresultPointCallback: TResultPointCallback;
class function centerFromEnd(stateCount: TArray<Integer>; pEnd: Integer): Single; static;
function crossCheckDiagonal(startI: Integer; centerJ: Integer; maxCount: Integer; originalStateCountTotal: Integer): boolean;
function crossCheckHorizontal(startJ: Integer; centerI: Integer; maxCount: Integer; originalStateCountTotal: Integer): Single;
function crossCheckVertical(startI: Integer; centerJ: Integer; maxCount: Integer; originalStateCountTotal: Integer): Single;
function findRowSkip: Integer;
function haveMultiplyConfirmedCenters: boolean;
function selectBestPatterns: TArray<IFinderPattern>;
function CrossCheckStateCount: TArray<Integer>;
protected
const
/// <summary>
/// 1 pixel/module times 3 modules/center
/// </summary>
MIN_SKIP: Integer = 3;
/// <summary>
/// support up to version 10 for mobile clients
/// </summary>
MAX_MODULES: Integer = 97;
class function foundPatternCross(const stateCount: TArray<Integer>): Boolean; static;
function handlePossibleCenter(stateCount: TArray<Integer>; i: Integer;
j: Integer): boolean;
property image: TBitMatrix read FImage;
public
/// <summary>
/// <p>Creates a finder that will search the image for three finder patterns.</p>
/// </summary>
/// <param name="image">image to search</param>
constructor Create(const image: TBitMatrix); overload;
/// <summary>
/// Initializes a new instance of the <see cref="FinderPatternFinder"/> class.
/// </summary>
/// <param name="image">The image.</param>
/// <param name="resultPointCallback">The result point callback.</param>
constructor Create(const image: TBitMatrix;
resultPointCallback: TResultPointCallback); overload;
destructor Destroy; override;
function find(const hints: TDictionary<TDecodeHintType, TObject>): TFinderPatternInfo; virtual;
end;
TFurthestFromAverageComparator = class sealed(TInterfacedObject,
IComparer<IFinderPattern>)
private
average: Single;
public
constructor Create(f: Single);
function Compare(const Left, Right: IFinderPattern): Integer;
end;
TCenterComparator = class sealed(TInterfacedObject, IComparer<IFinderPattern>)
private
average: Single;
public
constructor Create(f: Single);
function Compare(const Left, Right: IFinderPattern): Integer;
end;
implementation
{ TFinderPatternFinder }
constructor TFinderPatternFinder.Create(const image: TBitMatrix);
begin
Self.Create(image, TResultPointCallback(nil));
end;
constructor TFinderPatternFinder.Create(const image: TBitMatrix;
resultPointCallback: TResultPointCallback);
begin
FImage := image;
FPossibleCenters := TList<IFinderPattern>.Create;
FCrossCheckStateCount := TArray<Integer>.Create(0, 0, 0, 0, 0);
FresultPointCallback := resultPointCallback;
end;
destructor TFinderPatternFinder.Destroy;
begin
FImage := nil;
{for i := Pred(PossibleCenters.Count) downto 0 do
begin
PossibleCenters[i].Free;
PossibleCenters.Delete(i);
end;}
FPossibleCenters.Free;
FCrossCheckStateCount := nil;
inherited;
end;
class function TFinderPatternFinder.centerFromEnd(stateCount: TArray<Integer>;
pEnd: Integer): Single;
var
aResult: Single;
begin
aResult := (pEnd - stateCount[4] - stateCount[3]) - (stateCount[2] / 2);
if (Single.IsNaN(aResult)) then
begin
result := -1;
exit
end;
result := aResult;
end;
function TFinderPatternFinder.crossCheckDiagonal(startI, centerJ, maxCount,
originalStateCountTotal: Integer): boolean;
var
stateCount: TArray<Integer>;
i, maxI, maxJ, stateCountTotal: Integer;
begin
stateCount := CrossCheckStateCount;
try
i := 0;
while ((((startI >= i) and (centerJ >= i)) and self.image[(centerJ - i),
(startI - i)])) do
begin
inc(stateCount[2]);
inc(i)
end;
if ((startI < i) or (centerJ < i)) then
begin
result := false;
exit
end;
while (((((startI >= i) and (centerJ >= i)) and
not self.image[(centerJ - i), (startI - i)]) and
(stateCount[1] <= maxCount))) do
begin
inc(stateCount[1]);
inc(i)
end;
if (((startI < i) or (centerJ < i)) or (stateCount[1] > maxCount)) then
begin
result := false;
exit
end;
while (((((startI >= i) and (centerJ >= i)) and self.image[(centerJ - i),
(startI - i)]) and (stateCount[0] <= maxCount))) do
begin
inc(stateCount[0]);
inc(i)
end;
if (stateCount[0] > maxCount) then
begin
result := false;
exit
end;
maxI := self.image.Height;
maxJ := self.image.Width;
i := 1;
while (((((startI + i) < maxI) and ((centerJ + i) < maxJ)) and
self.image[(centerJ + i), (startI + i)])) do
begin
inc(stateCount[2]);
inc(i)
end;
if (((startI + i) >= maxI) or ((centerJ + i) >= maxJ)) then
begin
result := false;
exit
end;
while ((((((startI + i) < maxI) and ((centerJ + i) < maxJ)) and
not self.image[(centerJ + i), (startI + i)]) and
(stateCount[3] < maxCount))) do
begin
inc(stateCount[3]);
inc(i)
end;
if ((((startI + i) >= maxI) or ((centerJ + i) >= maxJ)) or
(stateCount[3] >= maxCount)) then
begin
result := false;
exit
end;
while ((((((startI + i) < maxI) and ((centerJ + i) < maxJ)) and
self.image[(centerJ + i), (startI + i)]) and
(stateCount[4] < maxCount))) do
begin
inc(stateCount[4]);
inc(i)
end;
if (stateCount[4] >= maxCount) then
begin
result := false;
exit
end;
stateCountTotal :=
((((stateCount[0] + stateCount[1]) + stateCount[2]) + stateCount[3]) +
stateCount[4]);
Result := (Abs(stateCountTotal - originalStateCountTotal) <
(2 * originalStateCountTotal)) and TFinderPatternFinder.foundPatternCross
(stateCount);
finally
stateCount := nil;
end;
end;
function TFinderPatternFinder.crossCheckHorizontal(startJ: Integer;
centerI: Integer; maxCount: Integer;
originalStateCountTotal: Integer): Single;
var
stateCount: TArray<Integer>;
maxJ, j, stateCountTotal: Integer;
begin
maxJ := FImage.Width;
stateCount := CrossCheckStateCount;
try
j := startJ;
while (((j >= 0) and FImage[j, centerI])) do
begin
inc(stateCount[2]);
dec(j)
end;
if (j < 0) then
begin
result := -1;
exit
end;
while ((((j >= 0) and not FImage[j, centerI]) and
(stateCount[1] <= maxCount))) do
begin
inc(stateCount[1]);
dec(j)
end;
if ((j < 0) or (stateCount[1] > maxCount)) then
begin
result := -1;
exit
end;
while ((((j >= 0) and FImage[j, centerI]) and
(stateCount[0] <= maxCount))) do
begin
inc(stateCount[0]);
dec(j)
end;
if (stateCount[0] > maxCount) then
begin
result := -1;
exit
end;
j := (startJ + 1);
while (((j < maxJ) and FImage[j, centerI])) do
begin
inc(stateCount[2]);
inc(j)
end;
if (j = maxJ) then
begin
result := -1;
exit
end;
while ((((j < maxJ) and not FImage[j, centerI]) and
(stateCount[3] < maxCount))) do
begin
inc(stateCount[3]);
inc(j)
end;
if ((j = maxJ) or (stateCount[3] >= maxCount)) then
begin
result := -1;
exit
end;
while (((j < maxJ) and FImage[j, centerI]) and
(stateCount[4] < maxCount)) do
begin
inc(stateCount[4]);
inc(j)
end;
if (stateCount[4] >= maxCount) then
begin
result := -1;
exit
end;
stateCountTotal :=
((((stateCount[0] + stateCount[1]) + stateCount[2]) + stateCount[3]) +
stateCount[4]);
if (5 * Abs(stateCountTotal - originalStateCountTotal) >=
originalStateCountTotal) then
begin
result := -1;
exit
end;
if TFinderPatternFinder.foundPatternCross(stateCount) then
begin
result := TFinderPatternFinder.centerFromEnd(stateCount, j);
exit;
end;
finally
stateCount := nil;
end;
result := -1;
end;
function TFinderPatternFinder.CrossCheckStateCount: TArray<Integer>;
begin
FCrossCheckStateCount[0] := 0;
FCrossCheckStateCount[1] := 0;
FCrossCheckStateCount[2] := 0;
FCrossCheckStateCount[3] := 0;
FCrossCheckStateCount[4] := 0;
result := FCrossCheckStateCount;
end;
function TFinderPatternFinder.crossCheckVertical(startI: Integer;
centerJ: Integer; maxCount: Integer;
originalStateCountTotal: Integer): Single;
var
stateCount: TArray<Integer>;
maxI, i, stateCountTotal: Integer;
begin
maxI := FImage.Height;
stateCount := CrossCheckStateCount;
i := startI;
try
while (((i >= 0) and FImage[centerJ, i])) do
begin
inc(stateCount[2]);
dec(i)
end;
if (i < 0) then
begin
result := -1;
exit
end;
while ((((i >= 0) and not FImage[centerJ, i]) and
(stateCount[1] <= maxCount))) do
begin
inc(stateCount[1]);
dec(i)
end;
if ((i < 0) or (stateCount[1] > maxCount)) then
begin
result := -1;
exit
end;
while ((((i >= 0) and FImage[centerJ, i]) and
(stateCount[0] <= maxCount))) do
begin
inc(stateCount[0]);
dec(i)
end;
if (stateCount[0] > maxCount) then
begin
result := -1;
exit
end;
i := (startI + 1);
while (((i < maxI) and FImage[centerJ, i])) do
begin
inc(stateCount[2]);
inc(i)
end;
if (i = maxI) then
begin
result := -1;
exit
end;
while ((((i < maxI) and not FImage[centerJ, i]) and
(stateCount[3] < maxCount))) do
begin
inc(stateCount[3]);
inc(i)
end;
if ((i = maxI) or (stateCount[3] >= maxCount)) then
begin
result := -1;
exit
end;
while ((((i < maxI) and FImage[centerJ, i]) and
(stateCount[4] < maxCount))) do
begin
inc(stateCount[4]);
inc(i)
end;
if (stateCount[4] >= maxCount) then
begin
result := -1;
exit
end;
stateCountTotal :=
((((stateCount[0] + stateCount[1]) + stateCount[2]) + stateCount[3]) +
stateCount[4]);
if ((5 * Abs(stateCountTotal - originalStateCountTotal)) >=
(2 * originalStateCountTotal)) then
begin
result := -1;
exit
end;
if TFinderPatternFinder.foundPatternCross(stateCount) then
begin
result := TFinderPatternFinder.centerFromEnd(stateCount, i);
exit;
end;
finally
stateCount := nil;
end;
result := -1;
end;
function TFinderPatternFinder.find(
const hints: TDictionary<TDecodeHintType, TObject>): TFinderPatternInfo;
var
tryHarder,
done, confirmed: Boolean;
maxI, maxJ, iSkip,
i, currentState, j, rowSkip: Integer;
stateCount: TArray<Integer>;
patternInfo: TArray<IFinderPattern>;
resultInfo: TArray<IResultPoint>;
begin
Result := nil;
tryHarder := (hints <> nil) and (hints.ContainsKey(ZXing.DecodeHinttype.TRY_HARDER));
maxI := Self.image.Height;
maxJ := Self.image.Width;
// We are looking for black/white/black/white/black modules in
// 1:1:3:1:1 ratio; this tracks the number of such modules seen so far
// Let's assume that the maximum version QR Code we support takes up 1/4 the height of the
// image, and then account for the center being 3 modules in size. This gives the smallest
// number of pixels the center could be, so skip this often. When trying harder, look for all
// QR versions regardless of how dense they are.
iSkip := (3 * maxI) div (4 * MAX_MODULES);
if (iSkip < MIN_SKIP) or (tryHarder)
then
iSkip := MIN_SKIP;
done := false;
stateCount := TArray<Integer>.Create(0, 0, 0, 0, 0);
try
i := (iSkip - 1);
while ((i < maxI) and (not done)) do
begin
// Get a row of black/white values
stateCount[0] := 0;
stateCount[1] := 0;
stateCount[2] := 0;
stateCount[3] := 0;
stateCount[4] := 0;
currentState := 0;
j := 0;
while (j < maxJ) do
begin
if (FImage[j, i]) then
begin
// Black pixel
if ((currentState and 1) = 1)
then
Inc(currentState);
Inc(stateCount[currentState]);
end else
begin
// White pixel
if ((currentState and 1) = 0) then
begin
// Counting black pixels
if (currentState = 4) then
begin
// A winner?
if TFinderPatternFinder.foundPatternCross(stateCount) then
begin
// Yes
confirmed := handlePossibleCenter(stateCount, i, j);
if (confirmed) then
begin
// Start examining every other line. Checking each line turned out to be too
// expensive and didn't improve performance.
iSkip := 2;
if (FhasSkipped)
then
done := haveMultiplyConfirmedCenters()
else
begin
rowSkip := findRowSkip();
if (rowSkip > stateCount[2]) then
begin
// Skip rows between row of lower confirmed center
// and top of presumed third confirmed center
// but back up a bit to get a full chance of detecting
// it, entire width of center of finder pattern
// Skip by rowSkip, but back off by stateCount[2] (size of last center
// of pattern we saw) to be conservative, and also back off by iSkip which
// is about to be re-added
Inc(i, ((rowSkip - stateCount[2]) - iSkip));
j := (maxJ - 1);
end;
end;
end else
begin
stateCount[0] := stateCount[2];
stateCount[1] := stateCount[3];
stateCount[2] := stateCount[4];
stateCount[3] := 1;
stateCount[4] := 0;
currentState := 3;
continue;
end;
// Clear state to start looking again
currentState := 0;
stateCount[0] := 0;
stateCount[1] := 0;
stateCount[2] := 0;
stateCount[3] := 0;
stateCount[4] := 0
end else
begin
// No, shift counts back by two
stateCount[0] := stateCount[2];
stateCount[1] := stateCount[3];
stateCount[2] := stateCount[4];
stateCount[3] := 1;
stateCount[4] := 0;
currentState := 3;
end;
end else
begin
Inc(currentState);
Inc(stateCount[currentState]);
end;
end else
// Counting white pixels
Inc(stateCount[currentState]);
end;
Inc(j);
end;
if foundPatternCross(stateCount) then
begin
confirmed := Self.handlePossibleCenter(stateCount, i, maxJ);
if (confirmed) then
begin
iSkip := stateCount[0];
if (FhasSkipped)
then
// Found a third one
done := self.haveMultiplyConfirmedCenters
end;
end;
Inc(i, iSkip);
end;
patternInfo := selectBestPatterns();
if (patternInfo = nil)
then
exit;
TFinderPatternHelpers.orderBestPatterns(patternInfo);
Result := TFinderPatternInfo.Create(patternInfo);
finally
resultInfo := nil;
stateCount := nil;
patternInfo := nil;
end;
end;
function TFinderPatternFinder.findRowSkip: Integer;
var
center: IFinderPattern;
firstConfirmedCenter: IResultPoint;
begin
Result := 0;
if (FPossibleCenters.Count > 1) then
begin
firstConfirmedCenter := nil;
for center in FPossibleCenters do
begin
if (center.Count >= 2) then
begin
if (firstConfirmedCenter <> nil) then
begin
FhasSkipped := true;
Result := Floor(Abs(firstConfirmedCenter.X - center.X) -
Abs(firstConfirmedCenter.Y - center.Y)) div 2;
exit;
end;
firstConfirmedCenter := center;
end
end
end;
end;
/// <param name="stateCount">count of black/white/black/white/black pixels just read
/// </param>
/// <returns> true iff the proportions of the counts is close enough to the 1/1/3/1/1 ratios
/// used by finder patterns to be considered a match
/// </returns>
class function TFinderPatternFinder.foundPatternCross(
const stateCount: TArray<Integer>): Boolean;
var
i, totalModuleSize,
count, moduleSize,
maxVariance: Integer;
begin
Result := false;
totalModuleSize := 0;
for i := 0 to Pred(5) do
begin
count := stateCount[i];
if (count = 0)
then
exit;
Inc(totalModuleSize, count);
end;
if (totalModuleSize < 7)
then
exit;
moduleSize := ((totalModuleSize shl 8) div 7);
maxVariance := (moduleSize div 2);
// Allow less than 50% variance from 1-1-3-1-1 proportions
Result := (Abs(moduleSize - (stateCount[0] shl INTEGER_MATH_SHIFT)) < maxVariance) and
(Abs(moduleSize - (stateCount[1] shl INTEGER_MATH_SHIFT)) < maxVariance) and
(Abs(3 * moduleSize - (stateCount[2] shl INTEGER_MATH_SHIFT)) < (3 * maxVariance)) and
(Abs(moduleSize - (stateCount[3] shl INTEGER_MATH_SHIFT)) < maxVariance) and
(Abs(moduleSize - (stateCount[4] shl INTEGER_MATH_SHIFT)) < maxVariance);
end;
function TFinderPatternFinder.handlePossibleCenter(stateCount: TArray<Integer>;
i, j: Integer): boolean;
var
stateCountTotal, index: Integer;
centerJ, centerI: Single;
center, point: IFinderPattern;
found: boolean;
estimatedModuleSize: Single;
begin
Result := false;
center := nil;
stateCountTotal := ((((stateCount[0] + stateCount[1]) + stateCount[2]) +
stateCount[3]) + stateCount[4]);
centerJ := TFinderPatternFinder.centerFromEnd(stateCount, j);
if (centerJ = -1)
then
exit;
centerI := self.crossCheckVertical(i, Floor(centerJ), stateCount[2],
stateCountTotal);
if (centerI = -1)
then
exit;
centerJ := crossCheckHorizontal(Floor(centerJ), Floor(centerI), stateCount[2],
stateCountTotal);
if ((centerJ <> -1) and (self.crossCheckDiagonal(Floor(centerI), Floor(centerJ), stateCount[2],
stateCountTotal))) then
begin
estimatedModuleSize := stateCountTotal / 7;
found := false;
index := 0;
while ((index < FPossibleCenters.Count)) do
begin
center := FPossibleCenters[index];
if (center.aboutEquals(estimatedModuleSize, centerI, centerJ)) then
begin
FPossibleCenters[index] := nil;
FPossibleCenters.Delete(index);
FPossibleCenters.Insert(index, center.combineEstimate(centerI, centerJ,
estimatedModuleSize));
found := true;
break;
end;
inc(index)
end;
if (not found) then
begin
point := TFinderPatternHelpers.CreateFinderPattern(centerJ, centerI, estimatedModuleSize);
FPossibleCenters.Add(point);
if Assigned(FresultPointCallback)
then
FresultPointCallBack(point);
end;
Result := true;
end;
end;
function TFinderPatternFinder.haveMultiplyConfirmedCenters: boolean;
var
confirmedCount, max, i: Integer;
totalModuleSize, average, totalDeviation: Single;
pattern: IFinderPattern;
begin
confirmedCount := 0;
totalModuleSize := 0;
max := FPossibleCenters.Count;
for pattern in FPossibleCenters do
begin
if (pattern.Count >= CENTER_QUORUM) then
begin
inc(confirmedCount);
totalModuleSize := totalModuleSize + pattern.estimatedModuleSize;
end;
end;
if (confirmedCount < 3) then
begin
result := false;
exit
end;
average := totalModuleSize / max;
totalDeviation := 0;
i := 0;
while ((i < max)) do
begin
pattern := FPossibleCenters[i];
totalDeviation := totalDeviation +
Abs(pattern.estimatedModuleSize - average);
inc(i)
end;
result := (totalDeviation <= (0.05 * totalModuleSize));
end;
function TFinderPatternFinder.selectBestPatterns: TArray<IFinderPattern>;
var
average, square, totalModuleSize: Double;
size, stdDev, limit, avrsng: Single;
center, possibleCenter, pattern: IFinderPattern;
startSize, i: Integer;
comparator: IComparer<IFinderPattern>;
begin
startSize := FPossibleCenters.Count;
if (startSize < 3) then
begin
result := nil;
exit
end;
if (startSize > 3) then
begin
totalModuleSize := 0;
square := 0;
for center in FPossibleCenters do
begin
size := center.estimatedModuleSize;
totalModuleSize := totalModuleSize + size;
square := square + (size * size);
end;
average := totalModuleSize / startSize;
stdDev := Sqrt((square / startSize) - (average * average));
// this intermediate assignment is a workaround for old-gen compilers
// that are not deallocating TFurthestFromAverageComparator instance
// (bug verified on XE8: just declare a destructor Destroy override
// in TFurthestFromAverageComparator put a breakpoint in it and see
// that the destructor never gets called if you don't use this intermediate
// assignment)
avrsng := average;
comparator := TFurthestFromAverageComparator.Create(avrsng);
FPossibleCenters.Sort(comparator);
limit := System.Math.Max((0.2 * avrsng), stdDev);
i := 0;
while (((i < FPossibleCenters.Count) and
(FPossibleCenters.Count > 3))) do
begin
pattern := FPossibleCenters[i];
if (Abs(pattern.estimatedModuleSize - average) > limit) then
begin
FPossibleCenters.Delete(i);
dec(i)
end;
inc(i)
end
end;
if (FPossibleCenters.Count > 3) then
begin
totalModuleSize := 0;
for possibleCenter in FPossibleCenters do
begin
totalModuleSize := totalModuleSize + possibleCenter.estimatedModuleSize;
end;
average := totalModuleSize / FPossibleCenters.Count;
// this intermediate assignment is a workaround for old-gen compilers
// that are not deallocating TCenterComparator instance
// (bug verified on XE8: just declare a destructor Destroy override in
// TCenterComparator,put a breakpoint in it and see that the destructor
// never gets called if you don't use this intermediate assignment)
comparator := TCenterComparator.Create(average);
FPossibleCenters.Sort( comparator );
// if (PossibleCenters.Count > 4) then
// begin
// self.PossibleCenters.DeleteRange(4, self.PossibleCenters.Count - 1);
// end;
end;
result := TArray<IFinderPattern>.Create(FPossibleCenters[0],
FPossibleCenters[1], FPossibleCenters[2]);
end;
{ TFurthestFromAverageComparator }
function TFurthestFromAverageComparator.Compare(const Left,
Right: IFinderPattern): Integer;
var
dA, dB: Single;
begin
dA := Abs(Right.estimatedModuleSize - self.average);
dB := Abs(Left.estimatedModuleSize - self.average);
if (dA < dB) then
begin
result := -1;
end
else if (dA = dB) then
begin
result := 0;
end
else
result := 1;
end;
constructor TFurthestFromAverageComparator.Create(f: Single);
begin
average := f;
end;
{ TCenterComparator }
function TCenterComparator.Compare(const Left, Right: IFinderPattern): Integer;
var
dA, dB: Single;
begin
if (Right.Count = Left.Count) then
begin
dA := Abs(Right.estimatedModuleSize - self.average);
dB := Abs(Left.estimatedModuleSize - self.average);
if (dA < dB) then
begin
result := 1;
end
else if (dA = dB) then
begin
result := 0;
end
else
result := -1;
exit;
end;
result := (Right.Count - Left.Count);
end;
constructor TCenterComparator.Create(f: Single);
begin
average := f;
end;
end.
@@ -0,0 +1,152 @@
{
* Copyright 2007 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Original Author: Sean Owen
* Delphi Implementation by E. Spelt and K. Gossens
}
unit ZXing.QrCode.Internal.FinderPatternImplementation;
interface
uses
ZXing.QrCode.Internal.FinderPattern;
function NewFinderPattern(const posX, posY, estimatedModuleSize: Single; const count: Integer):IFinderPattern; overload;
function NewFinderPattern(const posX, posY, estimatedModuleSize: Single):IFinderPattern; overload;
implementation
uses ZXing.ResultPoint,ZXing.ResultPointImplementation;
{ TFinderPattern }
type
/// <summary>
/// <p>Encapsulates a finder pattern, which are the three square patterns found in
/// the corners of QR Codes. It also encapsulates a count of similar finder patterns,
/// as a convenience to the finder's bookkeeping.</p>
/// </summary>
TFinderPattern = class(TResultPoint,IResultPoint,IFinderPattern)
private
Fcount: Integer;
FestimatedModuleSize: Single;
function GetCount:integer;
procedure SetCount(value:integer);
constructor Create(const posX, posY, estimatedModuleSize: Single;
const count: Integer); overload;
constructor Create(const posX, posY, estimatedModuleSize: Single); overload;
/// <summary> <p>Determines if this finder pattern "about equals" a finder pattern at the stated
/// position and size -- meaning, it is at nearly the same center with nearly the same size.</p>
/// </summary>
function aboutEquals(const moduleSize, i, j: Single): Boolean;
/// <summary>
/// Combines this object's current estimate of a finder pattern position and module size
/// with a new estimate. It returns a new {@code FinderPattern} containing a weighted average
/// based on count.
/// </summary>
/// <param name="i">The i.</param>
/// <param name="j">The j.</param>
/// <param name="newModuleSize">New size of the module.</param>
/// <returns></returns>
function combineEstimate(const i, j, newModuleSize: Single): IFinderPattern;
/// <summary>
/// Gets the size of the estimated module.
/// </summary>
/// <value>
/// The size of the estimated module.
/// </value>
function estimatedModuleSize : Single;
property count : Integer read GetCount write SetCount;
end;
constructor TFinderPattern.Create(const posX, posY,
estimatedModuleSize: Single; const count: Integer);
begin
inherited Create(posX, posY);
FestimatedModuleSize := estimatedModuleSize;
Fcount := count;
end;
constructor TFinderPattern.Create(const posX, posY,
estimatedModuleSize: Single);
begin
Self.Create(posX, posY, estimatedModuleSize, 1);
end;
function TFinderPattern.estimatedModuleSize: Single;
begin
result := FestimatedModuleSize;
end;
function TFinderPattern.GetCount: integer;
begin
result := FCount;
end;
function TFinderPattern.aboutEquals(const moduleSize, i, j: Single): Boolean;
var
moduleSizeDiff : Single;
begin
Result := false;
if ((Abs(i - y) <= moduleSize) and (Abs(j - x) <= moduleSize)) then
begin
moduleSizeDiff := Abs(moduleSize - self.estimatedModuleSize);
Result := ((moduleSizeDiff <= 1) or
(moduleSizeDiff <= self.estimatedModuleSize));
end;
end;
procedure TFinderPattern.SetCount(value: integer);
begin
FCount := value;
end;
function TFinderPattern.combineEstimate(const i, j,
newModuleSize: Single): IFinderPattern;
var
combinedCount: Integer;
combinedX, combinedY: Single;
begin
combinedCount := (Self.count + 1);
combinedX := ((Self.count * x) + j) / combinedCount;
combinedY := ((Self.count * y) + i) / combinedCount;
Result := TFinderPattern.Create(combinedX, combinedY,
(((Self.count * Self.estimatedModuleSize) + newModuleSize) / combinedCount),
combinedCount)
end;
function NewFinderPattern(const posX, posY, estimatedModuleSize: Single; const count: Integer):IFinderPattern;
begin
result := TFinderPattern.Create( posX, posY, estimatedModuleSize,count);
end;
function NewFinderPattern(const posX, posY, estimatedModuleSize: Single):IFinderPattern;
begin
result := TFinderPattern.Create( posX, posY, estimatedModuleSize);
end;
end.
@@ -0,0 +1,69 @@
{
* Copyright 2007 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Original Author: Sean Owen
* Delphi Implementation by E. Spelt and K. Gossens
}
unit ZXing.QrCode.Internal.FinderPatternInfo;
interface
uses
ZXing.QrCode.Internal.FinderPattern;
type
/// <summary>
/// <p>Encapsulates information about finder patterns in an image, including the location of
/// the three finder patterns, and their estimated module size.</p>
/// </summary>
TFinderPatternInfo = class sealed
private
FbottomLeft: IFinderPattern;
FtopLeft: IFinderPattern;
FtopRight: IFinderPattern;
public
/// <summary>
/// Initializes a new instance of the <see cref="FinderPatternInfo"/> class.
/// </summary>
/// <param name="patternCenters">The pattern centers.</param>
constructor Create(const patternCenters: TArray<IFinderPattern>);
/// <summary>
/// Gets the bottom left.
/// </summary>
property bottomLeft : IFinderPattern read FbottomLeft;
/// <summary>
/// Gets the top left.
/// </summary>
property topLeft : IFinderPattern read FtopLeft;
/// <summary>
/// Gets the top right.
/// </summary>
property topRight : IFinderPattern read FtopRight;
end;
implementation
constructor TFinderPatternInfo.Create(const patternCenters: TArray<IFinderPattern>);
begin
FbottomLeft := patternCenters[0];
FtopLeft := patternCenters[1];
FtopRight := patternCenters[2]
end;
end.
@@ -0,0 +1,258 @@
{
* Copyright 2007 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Original Author: bbrown@google.com (Brian Brown)
* Delphi Implementation by K. Gossens
}
unit ZXing.Datamatrix.DataMatrixReader;
interface
uses
System.SysUtils,
System.Generics.Collections,
ZXing.Common.Detector.MathUtils,
Math,
ZXing.Common.BitArray,
ZXing.BarcodeFormat,
ZXing.ReadResult,
ZXing.Reader,
ZXing.DecodeHintType,
ZXing.DecoderResult,
ZXing.Common.DetectorResult,
ZXing.ResultMetadataType,
ZXing.ResultPoint,
ZXing.Common.BitMatrix,
ZXing.BinaryBitmap,
ZXing.Datamatrix.Internal.Decoder,
ZXing.Datamatrix.Internal.Detector;
type
/// <summary>
/// This implementation can detect and decode Data Matrix codes in an image.
/// </summary>
TDataMatrixReader = class(TInterfacedObject, IReader)
private
FDecoder: TDataMatrixDecoder;
NO_POINTS: TArray<IResultPoint>;
/// <summary>
/// This method detects a code in a "pure" image -- that is, pure monochrome image
/// which contains only an unrotated, unskewed, image of a code, with some white border
/// around it. This is a specialized method that works exceptionally fast in this special
/// case.
///
/// <seealso cref="ZXing.QrCode.QRCodeReader.extractPureBits(TBitMatrix)" />
/// </summary>
class function extractPureBits(const image: TBitMatrix): TBitMatrix; static;
class function moduleSize(const leftTopBlack: TArray<Integer>;
const image: TBitMatrix; var moduleSize: Integer): Boolean; static;
public
constructor Create;
destructor Destroy; override;
/// <summary>
/// This implementation can detect and decode Data Matrix codes in an image.
/// </summary>
function decode(const image: TBinaryBitmap): TReadResult; overload;
function decode(const image: TBinaryBitmap;
hints: TDictionary<TDecodeHintType, TObject>): TReadResult; overload;
procedure reset;
end;
implementation
uses ZXing.ByteSegments;
{ TDataMatrixReader }
constructor TDataMatrixReader.Create;
begin
inherited;
FDecoder := TDataMatrixDecoder.Create;
NO_POINTS := TArray<IResultPoint>.Create();
end;
destructor TDataMatrixReader.Destroy;
begin
NO_POINTS := nil;
FDecoder.Free;
inherited;
end;
function TDataMatrixReader.decode(const image: TBinaryBitmap): TReadResult;
begin
Result := decode(image, nil);
end;
function TDataMatrixReader.decode(const image: TBinaryBitmap;
hints: TDictionary<TDecodeHintType, TObject>): TReadResult;
var
matrixDetector: TDataMatrixDetector;
DecoderResult: TDecoderResult;
points: TArray<IResultPoint>;
bits: TBitMatrix;
DetectorResult: TDetectorResult;
ByteSegments: IByteSegments;
begin
Result := nil;
DetectorResult := nil;
DecoderResult := nil;
try
if ((hints <> nil) and hints.ContainsKey(TDecodeHintType.PURE_BARCODE)) then
begin
bits := TDataMatrixReader.extractPureBits(image.BlackMatrix);
if Assigned(bits) then
begin
DecoderResult := FDecoder.decode(bits);
points := NO_POINTS;
FreeAndNil(bits);
end
else
exit;
end
else
begin
matrixDetector := TDataMatrixDetector.Create(image.BlackMatrix);
try
DetectorResult := matrixDetector.detect();
finally
matrixDetector.Free;
end;
if (DetectorResult = nil) then
exit;
DecoderResult := FDecoder.decode(DetectorResult.bits);
points := DetectorResult.points;
end;
if (DecoderResult = nil) then
exit;
Result := TReadResult.Create(DecoderResult.Text, DecoderResult.RawBytes,
points, TBarcodeFormat.DATA_MATRIX);
ByteSegments := DecoderResult.ByteSegments;
if (ByteSegments <> nil) then
Result.putMetadata(TResultMetadataType.BYTE_SEGMENTS, TResultMetaData.CreateByteSegmentsMetadata( byteSegments));
if (Length(DecoderResult.ECLevel) <> 0) then
Result.putMetadata(TResultMetadataType.ERROR_CORRECTION_LEVEL, TResultMetaData.CreateStringMetadata(DecoderResult.ECLevel));
finally
byteSegments:=nil;
if Assigned(DetectorResult) then
FreeAndNil(DetectorResult);
if Assigned(DecoderResult) then
FreeAndNil(DecoderResult);
end;
end;
class function TDataMatrixReader.extractPureBits(const image: TBitMatrix)
: TBitMatrix;
var
moduleSize: Integer;
leftTopBlack, rightBottomBlack: TArray<Integer>;
top, bottom, left, right: Integer;
matrixWidth, matrixHeight: Integer;
nudge: Integer;
bits: TBitMatrix;
x, y, iOffset: Integer;
begin
Result := nil;
leftTopBlack := image.getTopLeftOnBit;
rightBottomBlack := image.getBottomRightOnBit;
if ((leftTopBlack = nil) or (rightBottomBlack = nil)) then
exit;
if (not TDataMatrixReader.moduleSize(leftTopBlack, image, moduleSize)) then
exit;
top := leftTopBlack[1];
bottom := rightBottomBlack[1];
left := leftTopBlack[0];
right := rightBottomBlack[0];
matrixWidth := ((right - left + 1) div moduleSize);
matrixHeight := ((bottom - top + 1) div moduleSize);
if ((matrixWidth <= 0) or (matrixHeight <= 0)) then
exit;
// Push in the "border" by half the module width so that we start
// sampling in the middle of the module. Just in case the image is a
// little off, this will help recover.
nudge := TMathUtils.Asr(moduleSize,1);
Inc(top, nudge);
Inc(left, nudge);
// Now just read off the bits
bits := TBitMatrix.Create(matrixWidth, matrixHeight);
for y := 0 to Pred(matrixHeight) do
begin
iOffset := (top + (y * moduleSize));
for x := 0 to Pred(matrixWidth) do
begin
if (image[(left + (x * moduleSize)), iOffset]) then
bits[x, y] := true;
end;
end;
Result := bits;
end;
class function TDataMatrixReader.moduleSize(const leftTopBlack: TArray<Integer>;
const image: TBitMatrix; var moduleSize: Integer): Boolean;
var
width, x, y: Integer;
begin
Result := false;
width := image.width;
x := leftTopBlack[0];
y := leftTopBlack[1];
while ((x < width) and image[x, y]) do
Inc(x);
if (x = width) then
begin
moduleSize := 0;
exit;
end;
moduleSize := (x - leftTopBlack[0]);
if (moduleSize = 0) then
exit;
Result := true;
end;
procedure TDataMatrixReader.reset;
begin
// do nothing
end;
end.
@@ -0,0 +1,340 @@
{
* Copyright 2007 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Original Author: Sean Owen
* Delphi Implementation by E. Spelt and K. Gossens
}
unit ZXing.QrCode.QRCodeReader;
interface
uses
System.SysUtils,
System.Math,
System.Generics.Collections,
ZXing.Common.BitArray,
ZXing.ReadResult,
ZXing.Reader,
ZXing.DecodeHintType,
ZXing.BarcodeFormat,
ZXing.ResultPoint,
ZXing.BinaryBitmap,
ZXing.QrCode.Internal.Decoder,
ZXing.Common.BitMatrix,
ZXing.DecoderResult,
ZXing.ResultMetadataType,
ZXing.Common.DetectorResult,
ZXing.QrCode.Internal.QRCodeDecoderMetaData,
ZXing.QrCode.Internal.Detector,
ZXing.QrCode.Internal.DecodedBitStreamParser;
type
/// <summary>
/// This implementation can detect and decode QR Codes in an image.
/// </summary>
TQRCodeReader = class(TInterfacedObject, IReader)
private
FDecoder: TQRDecoder;
NO_POINTS: TArray<IResultPoint>;
/// <summary>
/// This method detects a code in a "pure" image -- that is, pure monochrome image
/// which contains only an unrotated, unskewed, image of a code, with some white border
/// around it. This is a specialized method that works exceptionally fast in this special
/// case.
///
/// <seealso cref="ZXing.Datamatrix.DataMatrixReader.extractPureBits(TBitMatrix)" />
/// </summary>
class function extractPureBits(const image: TBitMatrix): TBitMatrix; static;
class function moduleSize(const leftTopBlack: TArray<Integer>;
const image: TBitMatrix; var msize: Single): Boolean; static;
protected
/// <summary>
/// Gets the decoder.
/// </summary>
/// <returns></returns>
property Decoder: TQRDecoder read FDecoder;
public
constructor Create;
destructor Destroy; override;
/// <summary>
/// Locates and decodes a QR code in an image.
///
/// <returns>a String representing the content encoded by the QR code</returns>
/// </summary>
function decode(const image: TBinaryBitmap): TReadResult; overload;
/// <summary>
/// Locates and decodes a barcode in some format within an image. This method also accepts
/// hints, each possibly associated to some data, which may help the implementation decode.
/// </summary>
/// <param name="image">image of barcode to decode</param>
/// <param name="hints">passed as a <see cref="TDictionary{TKey, TValue}"/> from <see cref="TDecodeHintType"/>
/// to arbitrary data. The
/// meaning of the data depends upon the hint type. The implementation may or may not do
/// anything with these hints.</param>
/// <returns>
/// String which the barcode encodes
/// </returns>
function decode(const image: TBinaryBitmap;
hints: TDictionary<TDecodeHintType, TObject>): TReadResult; overload;
/// <summary>
/// Resets any internal state the implementation has after a decode, to prepare it
/// for reuse.
/// </summary>
procedure reset;
end;
implementation
uses ZXing.ByteSegments;
{ TQRCodeReader }
constructor TQRCodeReader.Create;
begin
inherited;
FDecoder := TQRDecoder.Create;
NO_POINTS := TArray<IResultPoint>.Create();
end;
destructor TQRCodeReader.Destroy;
begin
NO_POINTS := nil;
FDecoder.Free;
inherited;
end;
function TQRCodeReader.decode(const image: TBinaryBitmap): TReadResult;
begin
Result := Self.decode(image, nil);
end;
function TQRCodeReader.decode(const image: TBinaryBitmap;
hints: TDictionary<TDecodeHintType, TObject>): TReadResult;
var
DecoderResult: TDecoderResult;
Detector: TDetector;
points: TArray<IResultPoint>;
bits: TBitMatrix;
DetectorResult: TDetectorResult;
data: TQRCodeDecoderMetaData;
byteSegments: IByteSegments;
begin
Result := nil;
DecoderResult := nil;
if ((image = nil) or (image.BlackMatrix = nil)) then
// something is wrong with the image
exit;
try
if ((hints <> nil) and hints.ContainsKey(TDecodeHintType.PURE_BARCODE)) then
begin
bits := TQRCodeReader.extractPureBits(image.BlackMatrix);
if Assigned(bits) then
begin
DecoderResult := Decoder.decode(bits, hints);
points := NO_POINTS;
bits.Free;
end
else
exit;
end
else
begin
Detector := TDetector.Create(image.BlackMatrix);
try
DetectorResult := Detector.detect(hints);
if Assigned(DetectorResult) then
begin
DecoderResult := Decoder.decode(DetectorResult.bits, hints);
points := DetectorResult.points;
DetectorResult.Free;
end
else
exit;
finally
Detector.Free;
end;
end;
if (DecoderResult = nil) then
exit;
// If the code was mirrored: swap the bottom-left and the top-right points.
data := TQRCodeDecoderMetaData(DecoderResult.Other);
if (data <> nil) then
data.applyMirroredCorrection(points);
Result := TReadResult.Create(DecoderResult.Text, DecoderResult.RawBytes,
points, TBarcodeFormat.QR_CODE);
byteSegments := DecoderResult.byteSegments;
if (byteSegments <> nil) then
Result.putMetadata(TResultMetadataType.BYTE_SEGMENTS, TResultMetaData.CreateByteSegmentsMetadata(byteSegments));
if (Length(DecoderResult.ecLevel) <> 0) then
Result.putMetadata(TResultMetadataType.ERROR_CORRECTION_LEVEL, TResultMetaData.CreateStringMetadata(DecoderResult.ecLevel));
if (DecoderResult.StructuredAppend) then
begin
Result.putMetadata(TResultMetadataType.STRUCTURED_APPEND_SEQUENCE,
TResultMetaData.CreateIntegerMetadata(DecoderResult.StructuredAppendSequenceNumber));
Result.putMetadata(TResultMetadataType.STRUCTURED_APPEND_PARITY,
TResultMetaData.CreateIntegerMetadata(DecoderResult.StructuredAppendParity))
end;
finally
if Assigned(DecoderResult) then
FreeAndNil(DecoderResult);
end;
end;
procedure TQRCodeReader.reset;
begin
// do nothing
end;
class function TQRCodeReader.extractPureBits(const image: TBitMatrix)
: TBitMatrix;
var
moduleSize: Single;
leftTopBlack, rightBottomBlack: TArray<Integer>;
top, bottom, left, right, matrixWidth, matrixHeight, nudge, x, y, iOffset,
nudgedTooFarRight, nudgedTooFarDown: Integer;
bits: TBitMatrix;
begin
Result := nil;
leftTopBlack := image.getTopLeftOnBit;
rightBottomBlack := image.getBottomRightOnBit;
if ((leftTopBlack = nil) or (rightBottomBlack = nil)) then
exit;
if (not TQRCodeReader.moduleSize(leftTopBlack, image, moduleSize)) then
exit;
top := leftTopBlack[1];
bottom := rightBottomBlack[1];
left := leftTopBlack[0];
right := rightBottomBlack[0];
// Sanity check!
if ((left >= right) or (top >= bottom)) then
exit;
if ((bottom - top) <> (right - left)) then
// Special case, where bottom-right module wasn't black so we found something else in the last row
// Assume it's a square, so use height as the width
right := (left + (bottom - top));
matrixWidth := Round(((right - left) + 1) / moduleSize);
matrixHeight := Round(((bottom - top) + 1) / moduleSize);
if ((matrixWidth <= 0) or (matrixHeight <= 0)) then
exit;
if (matrixHeight <> matrixWidth) then
// Only possibly decode square regions
exit;
// Push in the "border" by half the module width so that we start
// sampling in the middle of the module. Just in case the image is a
// little off, this will help recover.
nudge := Trunc(moduleSize / 2.0);
Inc(top, nudge);
Inc(left, nudge);
// But careful that this does not sample off the edge
// "right" is the farthest-right valid pixel location -- right+1 is not necessarily
// This is positive by how much the inner x loop below would be too large
nudgedTooFarRight := left + Trunc((matrixWidth - 1) * moduleSize) - right;
if (nudgedTooFarRight > 0) then
begin
if (nudgedTooFarRight > nudge) then
// Neither way fits; abort
exit;
Dec(left, nudgedTooFarRight);
end;
// See logic above
nudgedTooFarDown := top + Trunc((matrixHeight - 1) * moduleSize) - bottom;
if (nudgedTooFarDown > 0) then
begin
if (nudgedTooFarDown > nudge) then
// Neither way fits; abort
exit;
Dec(top, nudgedTooFarDown);
end;
// Now just read off the bits
bits := TBitMatrix.Create(matrixWidth, matrixHeight);
for y := 0 to Pred(matrixHeight) do
begin
iOffset := top + Trunc(y * moduleSize);
for x := 0 to Pred(matrixWidth) do
begin
if (image[left + Trunc((x * moduleSize)), iOffset]) then
bits[x, y] := true;
end;
end;
Result := bits;
end;
class function TQRCodeReader.moduleSize(const leftTopBlack: TArray<Integer>;
const image: TBitMatrix; var msize: Single): Boolean;
var
height, width, x, y: Integer;
inBlack: Boolean;
transitions: Integer;
begin
Result := false;
height := image.height;
width := image.width;
x := leftTopBlack[0];
y := leftTopBlack[1];
inBlack := true;
transitions := 0;
while (((x < width) and (y < height))) do
begin
if (inBlack <> image[x, y]) then
begin
Inc(transitions);
if (transitions = 5) then
break;
inBlack := not inBlack;
end;
Inc(x);
Inc(y);
end;
if ((x = width) or (y = height)) then
begin
msize := 0.0;
exit;
end;
msize := ((x - leftTopBlack[0]) / 7.0);
Result := true;
end;
end.
@@ -0,0 +1,83 @@
unit ZXing.Common.Detector.MathUtils;
{
* Copyright 2008 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Implemented by E. Spelt for Delphi
* Restructured by K. Gossens
}
interface
uses
System.SysUtils;
type
TMathUtils = class sealed
public
class function distance(const aX, aY, bX, bY: Double): Single; static;
class function round(d: Single): Integer; static;
// class function Asr(x, y: integer): integer; overload; static;
class function Asr(Value: Int64; ShiftBits: integer): Int64; static;
end;
implementation
{ TMathUtils }
class function TMathUtils.distance(const aX, aY, bX, bY: Double): Single;
var
xDiff, yDiff: double;
begin
xDiff := aX - bX;
yDiff := aY - bY;
result := Sqrt(xDiff * xDiff + yDiff * yDiff);
end;
class function TMathUtils.round(d: Single): Integer;
begin
if (Single.IsNaN(d)) then
begin
Result := 0;
exit
end;
if (Single.IsPositiveInfinity(d)) then
begin
Result := $7fffffff;
exit;
end;
if (d < 0)
then
Result := Trunc(d + (-0.5))
else
Result := Trunc(d + 0.5);
end;
{
class function TMathUtils.Asr(x, y: integer): integer;
begin
result := x div (1 shl y);
end;
}
class function TMathUtils.Asr(Value: Int64; ShiftBits: integer): Int64;
begin
result := Value shr ShiftBits;
if (Value and $8000000000000000) > 0 then
result := result or ($FFFFFFFFFFFFFFFF shl (64 - ShiftBits));
end;
end.
@@ -0,0 +1,398 @@
{
* Copyright 2008 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Implemented by E. Spelt for Delphi
* Restructured by K. Gossens
}
unit ZXing.Common.Detector.WhiteRectangleDetector;
interface
uses
System.SysUtils,
ZXing.Common.BitMatrix,
ZXing.Common.Detector.MathUtils,
ZXing.ResultPoint;
type
TWhiteRectangleDetector = class sealed
private const
CORR: Integer = 1;
INIT_SIZE: Integer = 10;
var
downInit: Integer;
height: Integer;
image: TBitMatrix;
leftInit: Integer;
rightInit: Integer;
upInit: Integer;
width: Integer;
constructor Create(image: TBitMatrix); overload;
constructor Create(image: TBitMatrix; initSize: Integer; x: Integer;
y: Integer); overload;
function centerEdges(y: IResultPoint; z: IResultPoint; x: IResultPoint;
t: IResultPoint): TArray<IResultPoint>;
function containsBlackPoint(a: Integer; b: Integer; fixed: Integer;
horizontal: boolean): boolean;
function getBlackPointOnSegment(aX: Single; aY: Single; bX: Single;
bY: Single): IResultPoint;
public
class function New(image: TBitMatrix): TWhiteRectangleDetector; overload;
class function New(image: TBitMatrix; initSize: Integer; x: Integer;
y: Integer): TWhiteRectangleDetector; overload; static;
function detect(): TArray<IResultPoint>;
end;
implementation
{ TWhiteRectangleDetector }
constructor TWhiteRectangleDetector.Create(image: TBitMatrix);
begin
Self.Create(image, 10, image.width div 2, image.height div 2);
end;
constructor TWhiteRectangleDetector.Create(image: TBitMatrix; initSize: Integer;
x: Integer; y: Integer);
var
halfsize: Integer;
begin
Self.image := image;
Self.height := image.height;
Self.width := image.width;
halfsize := (initSize div 2);
Self.leftInit := (x - halfsize);
Self.rightInit := (x + halfsize);
Self.upInit := (y - halfsize);
Self.downInit := (y + halfsize);
end;
function TWhiteRectangleDetector.centerEdges(y: IResultPoint; z: IResultPoint;
x: IResultPoint; t: IResultPoint): TArray<IResultPoint>;
var
yi, yj, zi, zj, xi, xj, ti, tj: Single;
begin
yi := y.x;
yj := y.y;
zi := z.x;
zj := z.y;
xi := x.x;
xj := x.y;
ti := t.x;
tj := t.y;
if (yi < (Self.width div 2)) then
begin
Result := TArray<IResultPoint>.Create(TResultPointHelpers.CreateResultPoint((ti - 1), (tj + 1)
), TResultPointHelpers.CreateResultPoint((zi + 1), (zj + 1)), TResultPointHelpers.CreateResultPoint((xi - 1),
(xj - 1)), TResultPointHelpers.CreateResultPoint((yi + 1), (yj - 1)));
exit;
end;
Result := TArray<IResultPoint>.Create(TResultPointHelpers.CreateResultPoint((ti + 1), (tj + 1)),
TResultPointHelpers.CreateResultPoint((zi + 1), (zj - 1)), TResultPointHelpers.CreateResultPoint((xi - 1),
(xj + 1)), TResultPointHelpers.CreateResultPoint((yi - 1), (yj - 1)));
end;
function TWhiteRectangleDetector.containsBlackPoint(a: Integer; b: Integer;
fixed: Integer; horizontal: boolean): boolean;
var
x, y: Integer;
begin
if (horizontal) then
begin
x := a;
while ((x <= b)) do
begin
if (Self.image[x, fixed]) then
begin
Result := true;
exit;
end;
Inc(x)
end;
end
else
begin
y := a;
while ((y <= b)) do
begin
if (Self.image[fixed, y]) then
begin
Result := true;
exit;
end;
Inc(y);
end;
end;
Result := false;
end;
class function TWhiteRectangleDetector.New(image: TBitMatrix)
: TWhiteRectangleDetector;
var
instance: TWhiteRectangleDetector;
begin
Result := nil;
if (image <> nil) then
begin
instance := TWhiteRectangleDetector.Create(image);
if (((instance.upInit >= 0) and (instance.leftInit >= 0)) and
((instance.downInit < instance.height) and
(instance.rightInit < instance.width))) then
Result := instance
else
instance.Free;
end;
end;
class function TWhiteRectangleDetector.New(image: TBitMatrix; initSize: Integer;
x: Integer; y: Integer): TWhiteRectangleDetector;
var
instance: TWhiteRectangleDetector;
begin
instance := TWhiteRectangleDetector.Create(image, initSize, x, y);
if (((instance.upInit >= 0) and (instance.leftInit >= 0)) and
((instance.downInit < instance.height) and
(instance.rightInit < instance.width))) then
Result := instance
else
begin
instance.Free;
Result := nil;
end;
end;
function TWhiteRectangleDetector.detect: TArray<IResultPoint>;
var
left, right, up, down: Integer;
sizeExceeded, aBlackPointFoundOnBorder, atLeastOneBlackPointFoundOnBorder,
atLeastOneBlackPointFoundOnRight, atLeastOneBlackPointFoundOnBottom,
atLeastOneBlackPointFoundOnLeft, atLeastOneBlackPointFoundOnTop,
rightBorderNotWhite, bottomBorderNotWhite, leftBorderNotWhite,
topBorderNotWhite: boolean;
i: Integer;
z, t, x, y: IResultPoint;
maxSize: Integer;
begin
z := nil;
t := nil;
x := nil;
y := nil;
left := Self.leftInit;
right := Self.rightInit;
up := Self.upInit;
down := Self.downInit;
sizeExceeded := false;
aBlackPointFoundOnBorder := true;
atLeastOneBlackPointFoundOnBorder := false;
atLeastOneBlackPointFoundOnRight := false;
atLeastOneBlackPointFoundOnBottom := false;
atLeastOneBlackPointFoundOnLeft := false;
atLeastOneBlackPointFoundOnTop := false;
while (aBlackPointFoundOnBorder) do
begin
aBlackPointFoundOnBorder := false;
rightBorderNotWhite := true;
while ((rightBorderNotWhite or (not atLeastOneBlackPointFoundOnRight)) and
(right < Self.width)) do
begin
rightBorderNotWhite := Self.containsBlackPoint(up, down, right, false);
if (rightBorderNotWhite) then
begin
Inc(right);
aBlackPointFoundOnBorder := true;
atLeastOneBlackPointFoundOnRight := true;
end
else if (not atLeastOneBlackPointFoundOnRight) then
Inc(right);
end;
if (right >= Self.width) then
begin
sizeExceeded := true;
break;
end;
bottomBorderNotWhite := true;
while ((bottomBorderNotWhite or (not atLeastOneBlackPointFoundOnBottom)) and
(down < Self.height)) do
begin
bottomBorderNotWhite := Self.containsBlackPoint(left, right, down, true);
if (bottomBorderNotWhite) then
begin
Inc(down);
aBlackPointFoundOnBorder := true;
atLeastOneBlackPointFoundOnBottom := true;
end
else if (not atLeastOneBlackPointFoundOnBottom) then
Inc(down);
end;
if (down >= Self.height) then
begin
sizeExceeded := true;
break;
end;
leftBorderNotWhite := true;
while ((leftBorderNotWhite or (not atLeastOneBlackPointFoundOnLeft)) and
(left >= 0)) do
begin
leftBorderNotWhite := Self.containsBlackPoint(up, down, left, false);
if (leftBorderNotWhite) then
begin
Dec(left);
aBlackPointFoundOnBorder := true;
atLeastOneBlackPointFoundOnLeft := true;
end
else if (not atLeastOneBlackPointFoundOnLeft) then
Dec(left);
end;
if (left < 0) then
begin
sizeExceeded := true;
break;
end;
topBorderNotWhite := true;
while ((topBorderNotWhite or (not atLeastOneBlackPointFoundOnTop)) and
(up >= 0)) do
begin
topBorderNotWhite := Self.containsBlackPoint(left, right, up, true);
if (topBorderNotWhite) then
begin
Dec(up);
aBlackPointFoundOnBorder := true;
atLeastOneBlackPointFoundOnTop := true;
end
else if (not atLeastOneBlackPointFoundOnTop) then
Dec(up);
end;
if (up < 0) then
begin
sizeExceeded := true;
break;
end;
if (aBlackPointFoundOnBorder) then
atLeastOneBlackPointFoundOnBorder := true;
end;
if (not(not sizeExceeded and atLeastOneBlackPointFoundOnBorder)) then
begin
Result := nil;
exit;
end;
maxSize := (right - left);
i := 1;
while ((i < maxSize)) do
begin
z := Self.getBlackPointOnSegment(left, (down - i), (left + i), down);
if (z <> nil) then
break;
Inc(i);
end;
if (z = nil) then
begin
Result := nil;
exit;
end;
i := 1;
while ((i < maxSize)) do
begin
t := Self.getBlackPointOnSegment(left, (up + i), (left + i), up);
if (t <> nil) then
break;
Inc(i);
end;
if (t = nil) then
begin
Result := nil;
exit;
end;
i := 1;
while ((i < maxSize)) do
begin
x := Self.getBlackPointOnSegment(right, (up + i), (right - i), up);
if (x <> nil) then
break;
Inc(i);
end;
if (x = nil) then
begin
Result := nil;
exit;
end;
y := nil;
i := 1;
while ((i < maxSize)) do
begin
y := Self.getBlackPointOnSegment(right, (down - i), (right - i), down);
if (y <> nil) then
break;
Inc(i);
end;
if (y = nil) then
begin
Result := nil;
exit;
end;
Result := Self.centerEdges(y, z, x, t);
end;
function TWhiteRectangleDetector.getBlackPointOnSegment(aX: Single; aY: Single;
bX: Single; bY: Single): IResultPoint;
var
i, x, y, dist: Integer;
xStep, yStep: Single;
begin
dist := TMathUtils.round(TMathUtils.distance(aX, aY, bX, bY));
xStep := ((bX - aX) / dist);
yStep := ((bY - aY) / dist);
i := 0;
while ((i < dist)) do
begin
x := TMathUtils.round((aX + (i * xStep)));
y := TMathUtils.round((aY + (i * yStep)));
if (Self.image[x, y]) then
begin
Result := TResultPointHelpers.CreateResultPoint(x, y);
exit;
end;
Inc(i);
end;
Result := nil;
end;
end.
@@ -0,0 +1,693 @@
unit ZXing.Common.ReedSolomon.GenericGF;
{
* Copyright 2007 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Original Author: Sean Owen
* Delphi Implementation by E. Spelt and K. Gossens
}
// ES: two classes in one unit. This is to avoid circulair reference.
interface
uses SysUtils;
type
TGenericGF = class;
IGenericGFPoly = interface
['{9E56C626-16C5-4A5A-99B5-84559780EB9D}']
function get_Degree: Integer;
function get_isZero: boolean;
function get_field: TGenericGF;
function get_coefficients: TArray<Integer>;
property coefficients: TArray<Integer> read get_coefficients;
property degree: Integer read get_Degree;
property isZero: boolean read get_isZero;
property Field: TGenericGF read get_field;
function addOrSubtract(other: IGenericGFPoly): IGenericGFPoly;
function divide(other: IGenericGFPoly): TArray<IGenericGFPoly>;
function evaluateAt(a: Integer): Integer;
function getCoefficient(degree: Integer): Integer;
function multiply(scalar: Integer): IGenericGFPoly; overload;
function multiply(other: IGenericGFPoly): IGenericGFPoly; overload;
function multiplyByMonomial(degree: Integer; coefficient: Integer)
: IGenericGFPoly;
function ToString: string;
end;
/// <summary>
/// <p>This class contains utility methods for performing mathematical operations over
/// the Galois Fields. Operations use a given primitive polynomial in calculations.</p>
/// <p>Throughout this package, elements of the GF are represented as an {@code int}
/// for convenience and speed (but at the cost of memory).
/// </p>
/// </summary>
TGenericGF = class sealed
private
FexpTable: TArray<Integer>;
FGeneratorBase: Integer;
FlogTable: TArray<Integer>;
FZero: IGenericGFPoly;
FOne: IGenericGFPoly;
Fprimitive: Integer;
Fsize: Integer;
function get_GeneratorBase: Integer;
function get_One: IGenericGFPoly;
function get_Zero: IGenericGFPoly;
function get_Size: Integer;
class function get_AZTEC_DATA_10: TGenericGF; static;
class function get_AZTEC_DATA_12: TGenericGF; static;
class function get_AZTEC_DATA_6: TGenericGF; static;
class function get_AZTEC_PARAM: TGenericGF; static;
class function get_QR_CODE_FIELD_256: TGenericGF; static;
class function get_DATA_MATRIX_FIELD_256: TGenericGF; static;
class procedure InitializeClass(); static;
class procedure FinalizeClass(); static;
public
class var AZTEC_DATA_10: TGenericGF;
class var AZTEC_DATA_12: TGenericGF;
class var AZTEC_DATA_6: TGenericGF;
class var AZTEC_PARAM: TGenericGF;
class var DATA_MATRIX_FIELD_256: TGenericGF;
class var QR_CODE_FIELD_256: TGenericGF;
class var MAXICODE_FIELD_64: TGenericGF;
class var AZTEC_DATA_8: TGenericGF;
constructor Create(primitive, size, genBase: Integer);
destructor Destroy(); override;
function ToString: string; override;
class function addOrSubtract(a: Integer; b: Integer): Integer; static;
function multiply(a: Integer; b: Integer): Integer;
function buildMonomial(degree: Integer; coefficient: Integer)
: IGenericGFPoly;
function log(a: Integer): Integer;
function exp(a: Integer): Integer;
function inverse(a: Integer): Integer;
property GeneratorBase: Integer read get_GeneratorBase;
property size: Integer read get_Size;
property One: IGenericGFPoly read get_One;
property Zero: IGenericGFPoly read get_Zero;
end;
TGenericGFPoly = class sealed(TInterfacedObject, IGenericGFPoly)
private
Fcoefficients: TArray<Integer>;
Ffield: TGenericGF;
public
function get_Degree: Integer;
function get_isZero: boolean;
function get_field: TGenericGF;
function get_coefficients: TArray<Integer>;
property coefficients: TArray<Integer> read get_coefficients;
property degree: Integer read get_Degree;
property isZero: boolean read get_isZero;
property Field: TGenericGF read get_field;
constructor Create(Field: TGenericGF; coefficients: TArray<Integer>);
destructor Destroy(); override;
function addOrSubtract(other: IGenericGFPoly): IGenericGFPoly;
function divide(other: IGenericGFPoly): TArray<IGenericGFPoly>;
function evaluateAt(a: Integer): Integer;
function getCoefficient(degree: Integer): Integer;
function multiply(scalar: Integer): IGenericGFPoly; overload;
function multiply(other: IGenericGFPoly): IGenericGFPoly; overload;
function multiplyByMonomial(degree: Integer; coefficient: Integer)
: IGenericGFPoly;
function ToString: string; override;
end;
implementation
{ TGenericGF }
class procedure TGenericGF.InitializeClass();
begin
AZTEC_DATA_10 := get_AZTEC_DATA_10();
AZTEC_DATA_12 := get_AZTEC_DATA_12;
AZTEC_DATA_6 := get_AZTEC_DATA_6;
AZTEC_PARAM := get_AZTEC_PARAM;
DATA_MATRIX_FIELD_256 := get_DATA_MATRIX_FIELD_256;
QR_CODE_FIELD_256 := get_QR_CODE_FIELD_256;
MAXICODE_FIELD_64 := get_AZTEC_DATA_6;
AZTEC_DATA_8 := get_DATA_MATRIX_FIELD_256;
end;
class procedure TGenericGF.FinalizeClass;
begin
FreeAndNil(AZTEC_DATA_10);
FreeAndNil(AZTEC_DATA_12);
FreeAndNil(AZTEC_DATA_6);
FreeAndNil(AZTEC_PARAM);
FreeAndNil(DATA_MATRIX_FIELD_256);
FreeAndNil(QR_CODE_FIELD_256);
FreeAndNil(MAXICODE_FIELD_64);
FreeAndNil(AZTEC_DATA_8);
end;
constructor TGenericGF.Create(primitive, size, genBase: Integer);
var
x, i: Integer;
begin
self.Fprimitive := primitive;
Fsize := size;
FGeneratorBase := genBase;
self.FexpTable := TArray<Integer>.Create();
self.FlogTable := TArray<Integer>.Create();
SetLength(self.FexpTable, size);
SetLength(self.FlogTable, size);
x := 1;
i := 0;
while ((i < size)) do
begin
self.FexpTable[i] := x;
x := (x shl 1);
if (x >= size) then
begin
x := (x xor primitive);
x := (x and (size - 1))
end;
inc(i)
end;
i := 0;
while ((i < (size - 1))) do
begin
self.FlogTable[self.FexpTable[i]] := i;
inc(i)
end;
FZero := TGenericGFPoly.Create(self, TArray<Integer>.Create(0));
FOne := TGenericGFPoly.Create(self, TArray<Integer>.Create(1));
end;
destructor TGenericGF.Destroy;
begin
self.FexpTable := nil;
self.FlogTable := nil;
inherited;
end;
class function TGenericGF.addOrSubtract(a, b: Integer): Integer;
begin
Result := (a xor b)
end;
function TGenericGF.buildMonomial(degree, coefficient: Integer): IGenericGFPoly;
var
coefficients: TArray<Integer>;
begin
if (degree < 0) then
raise EArgumentException.Create('Wrong argument');
if (coefficient = 0) then
begin
Result := self.Zero;
exit
end;
coefficients := TArray<Integer>.Create();
SetLength(coefficients, degree + 1);
coefficients[0] := coefficient;
Result := TGenericGFPoly.Create(self, coefficients);
end;
function TGenericGF.exp(a: Integer): Integer;
begin
Result := self.FexpTable[a]
end;
class function TGenericGF.get_AZTEC_DATA_10: TGenericGF;
begin
Result := TGenericGF.Create($409, $400, 1);
end;
class function TGenericGF.get_AZTEC_DATA_12: TGenericGF;
begin
Result := TGenericGF.Create($1069, $1000, 1);
end;
class function TGenericGF.get_AZTEC_DATA_6: TGenericGF;
begin
Result := TGenericGF.Create($43, $40, 1);
end;
class function TGenericGF.get_AZTEC_PARAM: TGenericGF;
begin
Result := TGenericGF.Create($13, $10, 1);
end;
class function TGenericGF.get_DATA_MATRIX_FIELD_256: TGenericGF;
begin
Result := TGenericGF.Create($12D, $100, 1);
end;
function TGenericGF.get_GeneratorBase: Integer;
begin
Result := FGeneratorBase;
end;
function TGenericGF.get_One: IGenericGFPoly;
begin
Result := FOne;
end;
class function TGenericGF.get_QR_CODE_FIELD_256: TGenericGF;
begin
Result := TGenericGF.Create($11D, $100, 0);
end;
function TGenericGF.get_Size: Integer;
begin
Result := Fsize;
end;
function TGenericGF.get_Zero: IGenericGFPoly;
begin
Result := FZero;
end;
function TGenericGF.inverse(a: Integer): Integer;
begin
if (a = 0) then
raise Exception.Create('Artithmetic Exception');
Result := self.FexpTable[((self.size - self.FlogTable[a]) - 1)];
end;
function TGenericGF.log(a: Integer): Integer;
begin
if (a = 0) then
raise EArgumentException.Create('wrong argument');
Result := self.FlogTable[a];
end;
function TGenericGF.multiply(a, b: Integer): Integer;
begin
if ((a = 0) or (b = 0)) then
begin
Result := 0;
exit
end;
Result := self.FexpTable
[((self.FlogTable[a] + self.FlogTable[b]) mod (self.Fsize - 1))];
end;
function TGenericGF.ToString: string;
begin
Result := 'GF(0x' + Fprimitive.ToString() + ',' + size.ToString() + ')';
end;
/// /////////////////////////////////////////////////////////////////////////////
constructor TGenericGFPoly.Create(Field: TGenericGF;
coefficients: TArray<Integer>);
var
coefficientsLength, firstNonZero: Integer;
begin
coefficientsLength := Length(coefficients);
if (coefficientsLength = 0) then
raise EArgumentException.Create('Wrong arguments');
self.Ffield := Field;
if ((coefficientsLength > 1) and (coefficients[0] = 0)) then
begin
firstNonZero := 1;
while (((firstNonZero < coefficientsLength) and
(coefficients[firstNonZero] = 0))) do
begin
inc(firstNonZero)
end;
Fcoefficients := TArray<Integer>.Create();
if (firstNonZero = coefficientsLength) then
begin
SetLength(Fcoefficients, 1);
end
else
begin
SetLength(Fcoefficients, coefficientsLength - firstNonZero);
Fcoefficients := Copy(coefficients, firstNonZero, Length(Fcoefficients));
end
end
else
Fcoefficients := coefficients
end;
destructor TGenericGFPoly.Destroy;
begin
SetLength(Fcoefficients, 0);
Fcoefficients := nil;
Ffield := nil;
inherited;
end;
function TGenericGFPoly.addOrSubtract(other: IGenericGFPoly): IGenericGFPoly;
var
lengthDiff, i, y: Integer;
smallerCoefficients, largerCoefficients, temp, sumDiff: TArray<Integer>;
begin
if (not self.Ffield.Equals(other.field)) then
raise EArgumentException.Create
('GenericGFPolys do not have same GenericGF field');
if (self.isZero) then
begin
Result := other;
exit
end;
if (other.isZero) then
begin
Result := self;
exit
end;
smallerCoefficients := self.coefficients;
largerCoefficients := other.coefficients;
if (Length(smallerCoefficients) > Length(largerCoefficients)) then
begin
temp := smallerCoefficients;
smallerCoefficients := largerCoefficients;
largerCoefficients := temp
end;
sumDiff := TArray<Integer>.Create();
SetLength(sumDiff, Length(largerCoefficients));
lengthDiff := Length(largerCoefficients) - Length(smallerCoefficients);
for y := 0 to lengthDiff - 1 do
begin
sumDiff[y] := largerCoefficients[y]
end;
i := lengthDiff;
while (i < Length(largerCoefficients)) do
begin
sumDiff[i] := TGenericGF.addOrSubtract(smallerCoefficients[(i - lengthDiff)
], largerCoefficients[i]);
inc(i)
end;
Result := TGenericGFPoly.Create(self.Ffield, sumDiff);
end;
function TGenericGFPoly.divide(other: IGenericGFPoly): TArray<IGenericGFPoly>;
var
term, quotient, remainder, iterationQuotient: IGenericGFPoly;
degreeDifference, denominatorLeadingTerm, scale,
inverseDenominatorLeadingTerm: Integer;
begin
if (not self.Ffield.Equals(other.field)) then
raise EArgumentException.Create
('GenericGFPolys do not have same GenericGF field');
if (other.isZero) then
raise EArgumentException.Create('Divide by 0');
quotient := self.Ffield.Zero;
remainder := self;
denominatorLeadingTerm := other.getCoefficient(other.degree);
inverseDenominatorLeadingTerm := self.Ffield.inverse(denominatorLeadingTerm);
while (((remainder.degree >= other.degree) and not remainder.isZero)) do
begin
degreeDifference := (remainder.degree - other.degree);
scale := self.Ffield.multiply(remainder.getCoefficient(remainder.degree),
inverseDenominatorLeadingTerm);
term := other.multiplyByMonomial(degreeDifference, scale);
iterationQuotient := self.Ffield.buildMonomial(degreeDifference, scale);
quotient := quotient.addOrSubtract(iterationQuotient);
remainder := remainder.addOrSubtract(term)
end;
Result := TArray<IGenericGFPoly>.Create(quotient, remainder);
end;
function TGenericGFPoly.evaluateAt(a: Integer): Integer;
var
size, coefficient, i, y, l: Integer;
begin
Result := 0;
if (a = 0) then
begin
Result := self.getCoefficient(0);
exit
end;
size := Length(self.coefficients);
if (a = 1) then
begin
l := Length(self.coefficients) - 1;
for y := 0 to l do
begin
coefficient := coefficients[y];
Result := TGenericGF.addOrSubtract(Result, coefficient)
end;
exit
end;
Result := self.coefficients[0];
i := 1;
while ((i < size)) do
begin
Result := TGenericGF.addOrSubtract(self.Ffield.multiply(a, Result),
self.coefficients[i]);
inc(i)
end;
end;
function TGenericGFPoly.getCoefficient(degree: Integer): Integer;
begin
Result := Fcoefficients[Length(Fcoefficients) - 1 - degree]
end;
function TGenericGFPoly.get_coefficients: TArray<Integer>;
begin
Result := fcoefficients;
end;
function TGenericGFPoly.get_Degree: Integer;
begin
Result := Length(Fcoefficients) - 1;
end;
function TGenericGFPoly.get_field: TGenericGF;
begin
Result := FField;
end;
function TGenericGFPoly.get_isZero: boolean;
begin
Result := Fcoefficients[0] = 0;
end;
function TGenericGFPoly.multiply(other: IGenericGFPoly): IGenericGFPoly;
var
product, aCoefficients, bCoefficients: TArray<Integer>;
aLength, bLength, i, aCoeff, j: Integer;
begin
if (not self.Ffield.Equals(other.field)) then
raise EArgumentException.Create
('GenericGFPolys do not have same GenericGF field');
if (self.isZero or other.isZero) then
begin
Result := self.Ffield.Zero;
exit
end;
aCoefficients := self.coefficients;
aLength := Length(aCoefficients);
bCoefficients := other.coefficients;
bLength := Length(bCoefficients);
product := TArray<Integer>.Create();
SetLength(product, (aLength + bLength) - 1);
i := 0;
while ((i < aLength)) do
begin
aCoeff := aCoefficients[i];
j := 0;
while ((j < bLength)) do
begin
product[(i + j)] := TGenericGF.addOrSubtract(product[(i + j)],
self.Ffield.multiply(aCoeff, bCoefficients[j]));
inc(j)
end;
inc(i)
end;
Result := TGenericGFPoly.Create(self.Ffield, product);
end;
function TGenericGFPoly.multiply(scalar: Integer): IGenericGFPoly;
var
product: TArray<Integer>;
size, i: Integer;
begin
if (scalar = 0) then
begin
Result := self.Ffield.Zero;
exit
end;
if (scalar = 1) then
begin
Result := self;
exit
end;
size := Length(self.coefficients);
product := TArray<Integer>.Create();
SetLength(product, size);
i := 0;
while ((i < size)) do
begin
product[i] := self.Ffield.multiply(self.coefficients[i], scalar);
inc(i)
end;
Result := TGenericGFPoly.Create(self.Ffield, product);
end;
function TGenericGFPoly.multiplyByMonomial(degree, coefficient: Integer)
: IGenericGFPoly;
var
product: TArray<Integer>;
size, i: Integer;
begin
if (degree < 0) then
raise EArgumentException.Create('Wrong arguments');
if (coefficient = 0) then
begin
Result := self.Ffield.Zero;
exit
end;
size := Length(self.coefficients);
product := TArray<Integer>.Create();
SetLength(product, size + degree);
i := 0;
while ((i < size)) do
begin
product[i] := self.Ffield.multiply(self.coefficients[i], coefficient);
inc(i)
end;
Result := TGenericGFPoly.Create(self.Ffield, product);
end;
function TGenericGFPoly.ToString: string;
var
lResult: TStringBuilder;
degree, coefficient, alphaPower: Integer;
begin
lResult := TStringBuilder.Create((8 * self.degree));
degree := self.degree;
while ((degree >= 0)) do
begin
coefficient := self.getCoefficient(degree);
if (coefficient <> 0) then
begin
if (coefficient < 0) then
begin
lResult.Append(' - ');
coefficient := -1 * coefficient
end
else if (Result.Length > 0) then
lResult.Append(' + ');
if ((degree = 0) or (coefficient <> 1)) then
begin
alphaPower := self.Ffield.log(coefficient);
if (alphaPower = 0) then
lResult.Append('1')
else if (alphaPower = 1) then
lResult.Append('a')
else
begin
lResult.Append('a^');
lResult.Append(alphaPower)
end
end;
if (degree <> 0) then
if (degree = 1) then
lResult.Append('x')
else
begin
lResult.Append('x^');
lResult.Append(degree)
end
end;
dec(degree)
end;
Result := lResult.ToString();
end;
initialization
TGenericGF.InitializeClass();
finalization
TGenericGF.FinalizeClass();
end.
@@ -0,0 +1,297 @@
{
* Copyright 2008 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Original Authors: Sean Owen and William Rucklidge
* Delphi Implementation by E. Spelt and K. Gossens
}
unit ZXing.Common.ReedSolomon.ReedSolomonDecoder;
interface
uses
System.SysUtils,
// Hint: ZXing.Common.ReedSolomon.GenericGFPoly is implemented in GenericGF as second class
ZXing.Common.ReedSolomon.GenericGF;
type
/// <summary>
/// Implements Reed-Solomon encoding, as the name implies.
/// </summary>
TReedSolomonDecoder = class sealed
public
constructor Create(field: TGenericGF);
public
function decode(received: TArray<Integer>; twoS: Integer): boolean;
strict private
function findErrorLocations(errorLocator: IGenericGFPoly): TArray<Integer>;
strict private
function findErrorMagnitudes(errorEvaluator: IGenericGFPoly;
errorLocations: TArray<Integer>): TArray<Integer>;
private
function runEuclideanAlgorithm(a: IGenericGFPoly; b: IGenericGFPoly;
pR: Integer): TArray<IGenericGFPoly>;
strict private
field: TGenericGF;
end;
implementation
{ TReedSolomonDecoder }
constructor TReedSolomonDecoder.Create(field: TGenericGF);
begin
self.field := field
end;
function TReedSolomonDecoder.decode(received: TArray<Integer>;
twoS: Integer): boolean;
var
i, eval, position: Integer;
poly, syndrome, sigma, omega: IGenericGFPoly;
sigmaOmega: TArray<IGenericGFPoly>;
errorLocations: TArray<Integer>;
syndromeCoefficients, errorMagnitudes: TArray<Integer>;
noError: boolean;
begin
poly := TGenericGFPoly.Create(self.field, received);
syndromeCoefficients := TArray<Integer>.Create();
SetLength(syndromeCoefficients, twoS);
try
noError := true;
i := 0;
while ((i < twoS)) do
begin
eval := poly.evaluateAt(self.field.exp((i + self.field.GeneratorBase)));
syndromeCoefficients[((Length(syndromeCoefficients) - 1) - i)] := eval;
if (eval <> 0) then
noError := false;
inc(i)
end;
if (noError) then
begin
Result := true;
Exit;
end;
syndrome := TGenericGFPoly.Create(self.field, syndromeCoefficients);
sigmaOmega := self.runEuclideanAlgorithm(self.field.buildMonomial(twoS, 1),
syndrome, twoS);
if (sigmaOmega = nil) then
begin
Result := false;
Exit
end;
sigma := sigmaOmega[0];
errorLocations := self.findErrorLocations(sigma);
if (errorLocations = nil) then
begin
Result := false;
Exit
end;
omega := sigmaOmega[1];
errorMagnitudes := self.findErrorMagnitudes(omega, errorLocations);
i := 0;
while (i < Length(errorLocations)) do
begin
position := ((Length(received) - 1) - self.field.log(errorLocations[i]));
if (position < 0) then
begin
Result := false;
Exit
end;
received[position] := TGenericGF.addOrSubtract(received[position],
errorMagnitudes[i]);
inc(i)
end;
finally
SetLength(sigmaOmega, 0);
SetLength(syndromeCoefficients, 0);
end;
Result := true;
end;
function TReedSolomonDecoder.findErrorLocations(errorLocator: IGenericGFPoly)
: TArray<Integer>;
var
numErrors, e, i: Integer;
begin
numErrors := errorLocator.Degree;
if (numErrors = 1) then
begin
Result := TArray<Integer>.Create(errorLocator.getCoefficient(1));
Exit
end;
Result := TArray<Integer>.Create();
SetLength(Result, numErrors);
e := 0;
i := 1;
while (((i < self.field.Size) and (e < numErrors))) do
begin
if (errorLocator.evaluateAt(i) = 0) then
begin
Result[e] := self.field.inverse(i);
inc(e)
end;
inc(i);
end;
if (e <> numErrors) then
begin
Result := nil;
end;
end;
function TReedSolomonDecoder.findErrorMagnitudes(errorEvaluator: IGenericGFPoly;
errorLocations: TArray<Integer>): TArray<Integer>;
var
s, i, xiInverse, denominator, j, term, termPlus1: Integer;
begin
s := Length(errorLocations);
Result := TArray<Integer>.Create();
SetLength(Result, s);
i := 0;
while ((i < s)) do
begin
xiInverse := self.field.inverse(errorLocations[i]);
denominator := 1;
j := 0;
while ((j < s)) do
begin
if (i <> j) then
begin
term := self.field.multiply(errorLocations[j], xiInverse);
if ((term and 1) = 0) then
begin
termPlus1 := (term or 1)
end
else
begin
termPlus1 := (term and (not 1));
end;
denominator := self.field.multiply(denominator, termPlus1)
end;
inc(j)
end;
Result[i] := self.field.multiply(errorEvaluator.evaluateAt(xiInverse),
self.field.inverse(denominator));
if (self.field.GeneratorBase <> 0) then
Result[i] := self.field.multiply(Result[i], xiInverse);
inc(i)
end;
end;
function TReedSolomonDecoder.runEuclideanAlgorithm(a, b: IGenericGFPoly;
pR: Integer): TArray<IGenericGFPoly>;
var
temp, rLastLast, tLastLast, rLast, tLast, t, q, sigma, omega,
R: IGenericGFPoly;
denominatorLeadingTerm, dltInverse, degreeDiff, scale, inverse,
sigmaTildeAtZero: Integer;
begin
if (a.Degree < b.Degree) then
begin
temp := a;
a := b;
b := temp
end;
rLast := a;
R := b;
tLast := self.field.Zero;
t := self.field.One;
while ((R.Degree >= (pR div 2))) do
begin
rLastLast := rLast;
tLastLast := tLast;
rLast := R;
tLast := t;
if (rLast.isZero) then
begin
Result := nil;
Exit
end;
R := rLastLast;
q := self.field.Zero;
denominatorLeadingTerm := rLast.getCoefficient(rLast.Degree);
dltInverse := self.field.inverse(denominatorLeadingTerm);
while (((R.Degree >= rLast.Degree) and not R.isZero)) do
begin
degreeDiff := (R.Degree - rLast.Degree);
scale := self.field.multiply(R.getCoefficient(R.Degree), dltInverse);
q := q.addOrSubtract(self.field.buildMonomial(degreeDiff, scale));
R := R.addOrSubtract(rLast.multiplyByMonomial(degreeDiff, scale))
end;
t := q.multiply(tLast).addOrSubtract(tLastLast);
if (R.Degree >= rLast.Degree) then
begin
Result := nil;
Exit
end
end;
sigmaTildeAtZero := t.getCoefficient(0);
if (sigmaTildeAtZero = 0) then
begin
Result := nil;
Exit
end;
inverse := self.field.inverse(sigmaTildeAtZero);
sigma := t.multiply(inverse);
omega := R.multiply(inverse);
Result := TArray<IGenericGFPoly>.Create(sigma, omega);
end;
end.
@@ -0,0 +1,96 @@
unit ZXIng.ByteSegments;
interface
type
/// <summary>
/// implements the ByteSegments (which was declared as a TList<TArray<Byte>>
/// throughout the code as reference-counted interface object)
/// </summary>
IByteSegments = Interface
['{0994FC90-E8F5-40D8-8A48-9B05DFFF2635}']
function Count:integer;
procedure Clear;
function GetCapacity: integer;
procedure SetCapacity(const Value: integer);
property Capacity:integer read GetCapacity write SetCapacity;
function Add(const item:TArray<byte>):integer;
function Get(index: integer):TArray<byte>;
end;
function ByteSegmentsCreate:IByteSegments;
implementation
uses system.SysUtils,
Generics.Collections;
type
TByteSegments = class(TInterfacedObject,IByteSegments)
private
FList: TList<TArray<Byte>>;
function Count:integer;
procedure Clear;
constructor Create;
function GetCapacity: integer;
procedure SetCapacity(const Value: integer);
function Add(const item:TArray<byte>):integer;
function Get(index: integer):TArray<byte>;
public
destructor Destroy; override;
end;
function ByteSegmentsCreate:IByteSegments;
begin
result := TByteSegments.Create;
end;
{ TByteSegments }
function TByteSegments.Add(const item: TArray<byte>): integer;
begin
result := FList.Add(item);
end;
procedure TByteSegments.Clear;
begin
FList.Clear;
end;
function TByteSegments.Count: integer;
begin
result := FList.Count;
end;
constructor TByteSegments.Create;
begin
FList := TList<TArray<Byte>>.Create;
inherited Create;
end;
destructor TByteSegments.Destroy;
begin
FList.Free;
inherited;
end;
function TByteSegments.GetCapacity: integer;
begin
result := FList.Capacity;
end;
procedure TByteSegments.SetCapacity(const Value: integer);
begin
FList.Capacity := value;
end;
function TByteSegments.Get(index: Integer) : TArray<byte>;
begin
Result := FList[index];
end;
end.
@@ -0,0 +1,89 @@
{
* Copyright 2008 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Implemented by E. Spelt for Delphi
}
unit ZXing.BarcodeFormat;
interface
type
TBarcodeFormat = (
/// <summary>No format set. All formats will be used</summary>
Auto = 0,
/// <summary>Aztec 2D barcode format.</summary>
AZTEC = 1,
/// <summary>CODABAR 1D format.</summary>
CODABAR = 2,
/// <summary>Code 39 1D format.</summary>
CODE_39 = 4,
/// <summary>Code 93 1D format.</summary>
CODE_93 = 8,
/// <summary>Code 128 1D format.</summary>
CODE_128 = 16,
/// <summary>Data Matrix 2D barcode format.</summary>
DATA_MATRIX = 32,
/// <summary>EAN-8 1D format.</summary>
EAN_8 = 64,
/// <summary>EAN-13 1D format.</summary>
EAN_13 = 128,
/// <summary>ITF (Interleaved Two of Five) 1D format.</summary>
ITF = 256,
/// <summary>MaxiCode 2D barcode format.</summary>
MAXICODE = 512,
/// <summary>PDF417 format.</summary>
PDF_417 = 1024,
/// <summary>QR Code 2D barcode format.</summary>
QR_CODE = 2048,
/// <summary>RSS 14</summary>
RSS_14 = 4096,
/// <summary>RSS EXPANDED</summary>
RSS_EXPANDED = 8192,
/// <summary>UPC-A 1D format.</summary>
UPC_A = 16384,
/// <summary>UPC-E 1D format.</summary>
UPC_E = 32768,
/// <summary>UPC/EAN extension format. Not a stand-alone format.</summary>
UPC_EAN_EXTENSION = 65536,
/// <summary>MSI</summary>
MSI = 131072,
/// <summary>Plessey</summary>
PLESSEY = 262144
);
implementation
end.
@@ -0,0 +1,110 @@
unit ZXing.BitSource;
{
* Copyright 2008 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Implemented by E. Spelt for Delphi
}
interface
uses
SysUtils,
ZXing.Common.Detector.MathUtils;
type
TBitSource = class sealed
private
bytes: TArray<Byte>;
public
BitOffset: Integer;
ByteOffset: Integer;
constructor Create(bytes: TArray<Byte>);
function available: Integer;
function readBits(numBits: Integer): Integer;
end;
implementation
{ TBitSource }
function TBitSource.available: Integer;
begin
Result := 8 * (Length(self.bytes) - self.ByteOffset) - self.BitOffset;
end;
constructor TBitSource.Create(bytes: TArray<Byte>);
begin
self.bytes := bytes;
end;
function TBitSource.readBits(numBits: Integer): Integer;
var
bitsToNotRead, bitsLeft, toRead, mask: Integer;
begin
if (((numBits < 1) or (numBits > $20)) or (numBits > available())) then
raise EArgumentException.Create(numBits.ToString + 'numBits');
Result := 0;
if (BitOffset > 0) then
begin
bitsLeft := 8 - BitOffset;
if (numBits < bitsLeft) then
toRead := numBits
else
toRead := bitsLeft;
bitsToNotRead := (bitsLeft - toRead);
mask := TMathUtils.Asr($FF, ((8 - toRead) and $1F)) shl bitsToNotRead;
Result := TMathUtils.Asr((self.bytes[self.ByteOffset] and mask),
bitsToNotRead);
dec(numBits, toRead);
inc(BitOffset, toRead);
if (BitOffset = 8) then
begin
BitOffset := 0;
inc(ByteOffset)
end
end;
if (numBits > 0) then
begin
while ((numBits >= 8)) do
begin
Result := ((Result shl 8) or (self.bytes[self.ByteOffset] and $FF));
inc(self.ByteOffset);
dec(numBits, 8)
end;
if (numBits > 0) then
begin
bitsToNotRead := 8 - numBits;
mask := TMathUtils.Asr($FF, bitsToNotRead) shl bitsToNotRead;
Result := (Result shl numBits) or
TMathUtils.Asr((bytes[ByteOffset] and mask), bitsToNotRead);
inc(BitOffset, numBits)
end
end;
end;
end.
@@ -0,0 +1,180 @@
unit ZXing.CharacterSetECI;
{
* Copyright 2008 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Implemented by E. Spelt for Delphi
}
interface
uses SysUtils, Generics.Collections;
type
TECI = class abstract
private
value_Renamed: Integer;
constructor Create(value_Renamed: Integer);
public
class function getECIByValue(value_Renamed: Integer): TECI; static;
property value: Integer read value_Renamed;
end;
TCharacterSetECI = class sealed(TECI)
strict private
FEncodingName: string;
class var NAME_TO_ECI: TDictionary<string, TCharacterSetECI>;
class var VALUE_TO_ECI: TDictionary<Integer, TCharacterSetECI>;
///<summary>
/// this objectlist is just for doing proper deallocation of TCharacterSetECI instances under Win32/Win64,
/// without having to mess with TInterfacedObject. Since instances are meant to exist for the whole program life, there's no need of doing
/// anything much more complicated than this.
/// </summary>
class var AllocatedInstances:TObjectList<TCharacterSetECI>;
class constructor Create;
constructor Create(value: Integer; encodingName: string); overload;
class destructor Destroy;
class procedure addCharacterSet(value: Integer; encodingNames: TArray<string>); static;
public
property encodingName: string read FEncodingName;
class function getCharacterSetECIByName(name: string)
: TCharacterSetECI; static;
class function getCharacterSetECIByValue(value: Integer)
: TCharacterSetECI; static;
end;
implementation
{ TECI }
constructor TECI.Create(value_Renamed: Integer);
begin
self.value_Renamed := value_Renamed
end;
class function TECI.getECIByValue(value_Renamed: Integer): TECI;
begin
if ((value_Renamed < 0) or (value_Renamed > $F423F)) then
raise EArgumentException.Create('Bad ECI value: ' +
value_Renamed.ToString());
if (value_Renamed < 900) then
begin
Result := TCharacterSetECI.getCharacterSetECIByValue(value_Renamed);
exit
end;
Result := nil;
end;
{ TCharacterSetECI }
constructor TCharacterSetECI.Create(value: Integer; encodingName: string);
begin
inherited Create(value);
FEncodingName := encodingName;
AllocatedInstances.Add(self); // add the instance to the global list of all created instances
end;
class destructor TCharacterSetECI.Destroy;
begin
NAME_TO_ECI.Free;
VALUE_TO_ECI.Free;
if AllocatedInstances<>nil then begin
AllocatedInstances.Clear;
AllocatedInstances.Free;
end;
end;
class constructor TCharacterSetECI.Create;
begin
NAME_TO_ECI:=TDictionary<string, TCharacterSetECI>.Create;
VALUE_TO_ECI:=TDictionary<Integer, TCharacterSetECI>.Create;
// under Win32/64 TObjectList by default "OWNS" the objects it contains:
// if we clear the list, the objects contained get automatically destroyed
AllocatedInstances:= TObjectList<TCharacterSetECI>.Create;
TCharacterSetECI.addCharacterSet( 0, ['CP437']);
TCharacterSetECI.addCharacterSet( 1, ['ISO-8859-1','ISO8859_1']);
TCharacterSetECI.addCharacterSet( 2, ['CP437']);
TCharacterSetECI.addCharacterSet( 3, ['ISO-8859-1', 'ISO8859_1']);
TCharacterSetECI.addCharacterSet( 4, ['ISO-8859-2', 'ISO8859_2']);
TCharacterSetECI.addCharacterSet( 5, ['ISO-8859-3', 'ISO8859_3']);
TCharacterSetECI.addCharacterSet( 6, ['ISO-8859-4', 'ISO8859_4']);
TCharacterSetECI.addCharacterSet( 7, ['ISO-8859-5', 'ISO8859_5']);
TCharacterSetECI.addCharacterSet( 8, ['ISO-8859-6', 'ISO8859_6']);
TCharacterSetECI.addCharacterSet( 9, ['ISO-8859-7', 'ISO8859_7']);
TCharacterSetECI.addCharacterSet( 10, ['ISO-8859-8', 'ISO8859_8']);
TCharacterSetECI.addCharacterSet( 11, ['ISO-8859-9', 'ISO8859_9']);
TCharacterSetECI.addCharacterSet( 12, ['ISO-8859-4', 'ISO-8859-10', 'ISO8859_10']);
TCharacterSetECI.addCharacterSet( 13, ['ISO-8859-11', 'ISO8859_11']);
TCharacterSetECI.addCharacterSet( 15, ['ISO-8859-13', 'ISO8859_13']);
TCharacterSetECI.addCharacterSet($10, ['ISO-8859-1', 'ISO-8859-14', 'ISO8859_14']);
TCharacterSetECI.addCharacterSet($11, ['ISO-8859-15', 'ISO8859_15']);
TCharacterSetECI.addCharacterSet($12, ['ISO-8859-3', 'ISO-8859-16', 'ISO8859_16']);
TCharacterSetECI.addCharacterSet( 20, ['SJIS', 'Shift_JIS']);
TCharacterSetECI.addCharacterSet($15, ['WINDOWS-1250','CP1250']);
TCharacterSetECI.addCharacterSet($16, ['WINDOWS-1251','CP1251']);
TCharacterSetECI.addCharacterSet($17, ['WINDOWS-1252','CP1252']);
TCharacterSetECI.addCharacterSet($18, ['WINDOWS-1256', 'CP1256']);
TCharacterSetECI.addCharacterSet($19, ['UTF-16BE','UNICODEBIG']);
TCharacterSetECI.addCharacterSet($1A, ['UTF-8', 'UTF8']);
TCharacterSetECI.addCharacterSet($1B, ['US-ASCII']);
TCharacterSetECI.addCharacterSet(170, ['US-ASCII']);
TCharacterSetECI.addCharacterSet($1C, ['BIG5']);
TCharacterSetECI.addCharacterSet($1D, ['GB18030', 'GB2312', 'EUC_CN', 'GBK'] );
TCharacterSetECI.addCharacterSet( 30, ['EUC-KR', 'EUC_KR']);
end;
class procedure TCharacterSetECI.addCharacterSet(value: Integer; encodingNames: TArray<string>);
var
t: string;
Eci: TCharacterSetECI;
begin
Eci := TCharacterSetECI.Create(value, encodingNames[0]);
TCharacterSetECI.VALUE_TO_ECI.AddOrSetValue(value,Eci); // note : VALUE_TO_ECI[value] := Eci raises "key not found exception": it cant' be used for adding not existing values
for t in encodingNames do
TCharacterSetECI.NAME_TO_ECI.AddOrSetValue(t,Eci);
end;
class function TCharacterSetECI.getCharacterSetECIByName(name: string)
: TCharacterSetECI;
begin
Result := TCharacterSetECI.NAME_TO_ECI[name.ToUpper]
end;
class function TCharacterSetECI.getCharacterSetECIByValue(value: Integer)
: TCharacterSetECI;
begin
if ((value < 0) or (value >= 900)) then
begin
Result := nil;
exit
end;
Result := TCharacterSetECI.VALUE_TO_ECI[value];
end;
end.
@@ -0,0 +1,70 @@
{
* Copyright 2008 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Original Author: Sean Owen
* Delphi Implementation by E. Spelt and K. Gossens
}
unit ZXing.Common.BitArray;
interface
type
IBitArray = interface
['{3D65F451-E408-4015-A637-73CD05877BCB}']
// property getters and setters
function GetBit(i: Integer): Boolean;
procedure SetBit(i: Integer; Value: Boolean);
function GetBits: TArray<Integer>;
function Size: Integer;
function SizeInBytes: Integer;
property Self[i: Integer]: Boolean read GetBit write SetBit; default;
property Bits: TArray<Integer> read GetBits;
function getNextSet(from: Integer): Integer;
function getNextUnset(from: Integer): Integer;
procedure setBulk(i, newBits: Integer);
procedure setRange(start, ending: Integer);
procedure appendBit(bit: Boolean);
procedure Reverse();
procedure clear();
function isRange(start, ending: Integer; const value: Boolean): Boolean;
end;
TBitArrayHelpers = class
class function CreateBitArray:IBitArray; overload;
class function CreateBitArray(const Size: Integer):IBitArray; overload;
end;
implementation
uses ZXing.Common.BitArrayImplementation;
class function TBitArrayHelpers.CreateBitArray:IBitArray;
begin
result := ZXing.Common.BitArrayImplementation.NewBitArray;
end;
class function TBitArrayHelpers.CreateBitArray(const Size: Integer):IBitArray;
begin
result := ZXing.Common.BitArrayImplementation.NewBitArray(size);
end;
end.
@@ -0,0 +1,468 @@
unit ZXing.Common.BitArrayImplementation;
interface
uses ZXing.Common.BitArray;
function NewBitArray:IBitArray; overload;
function NewBitArray(const Size: Integer):IBitArray; overload;
implementation
uses
System.SysUtils,
ZXing.Common.Detector.MathUtils,
Math;
type
/// <summary>
/// A simple, fast array of bits, represented compactly by an array of ints internally.
/// </summary>
TBitArrayImplementation = class(TInterfacedObject, IBitArray)
strict private
_lookup: TArray<Integer>;
Fbits: TArray<Integer>;
Fsize: Integer;
procedure InitLookup();
function GetBit(i: Integer): Boolean;
procedure SetBit(i: Integer; Value: Boolean);
function makeArray(Size: Integer): TArray<Integer>;
procedure ensureCapacity(size: Integer);
function numberOfTrailingZeros(num: Integer): Integer;
function GetBits: TArray<Integer>;
private
constructor Create(); overload;
constructor Create(const Size: Integer); overload;
public
function Size: Integer;
function SizeInBytes: Integer;
property Self[i: Integer]: Boolean read GetBit write SetBit; default;
property Bits: TArray<Integer> read Fbits;
destructor Destroy; override;
function getNextSet(from: Integer): Integer;
function getNextUnset(from: Integer): Integer;
procedure setBulk(i, newBits: Integer);
procedure setRange(start, ending: Integer);
procedure appendBit(bit: Boolean);
procedure Reverse();
procedure clear();
function isRange(start, ending: Integer;
const value: Boolean): Boolean;
end;
constructor TBitArrayImplementation.Create;
begin
Fsize := 0;
SetLength(Fbits, 1);
InitLookup();
end;
constructor TBitArrayImplementation.Create(const Size: Integer);
begin
if (Size < 1)
then
raise EArgumentException.Create('size must be at least 1.');
Fsize := Size;
Fbits := makeArray(Size);
InitLookup();
end;
procedure TBitArrayImplementation.ensureCapacity(size: Integer);
var
newBits : TArray<Integer>;
begin
if (size > TMathUtils.Asr(Length(Fbits), 5)) then
begin
newBits := makeArray(size);
Move(Fbits[0], newBits[0], Length(Fbits) * SizeOf(Fbits[0]));
Fbits := newBits;
end;
end;
destructor TBitArrayImplementation.Destroy;
begin
Fbits := nil;
_lookup := nil;
inherited;
end;
function TBitArrayImplementation.GetBit(i: Integer): Boolean;
begin
Result := ((Fbits[TMathUtils.Asr(i, 5)]) and (1 shl (i and $1F))) <> 0;
end;
function TBitArrayImplementation.GetBits: TArray<Integer>;
begin
result := FBits;
end;
/// <summary>
/// Gets the next set.
/// </summary>
/// <param name="from">first bit to check</param>
/// <returns>index of first bit that is set, starting from the given index, or size if none are set
/// at or beyond this given index</returns>
function TBitArrayImplementation.getNextSet(from: Integer): Integer;
var
bitsOffset,
currentBits : Integer;
begin
if (from >= Fsize) then
Exit(FSize);
bitsOffset := TMathUtils.Asr(from, 5);
currentBits := Fbits[bitsOffset];
// mask off lesser bits first
{$OVERFLOWCHECKS OFF}
currentBits := currentBits and -(1 shl (from and $1F));
{$OVERFLOWCHECKS ON}
while (currentBits = 0) do
begin
Inc(bitsOffset);
if (bitsOffset = Length(Fbits)) then
Exit(FSize);
currentBits := Fbits[bitsOffset];
end;
Result := (bitsOffset shl 5) + numberOfTrailingZeros(currentBits);
Result := Math.Min(Result, FSize);
end;
/// <summary>
/// see getNextSet(int)
/// </summary>
/// <param name="from">index to start looking for unset bit</param>
/// <returns>index of next unset bit, or <see cref="Size"/> if none are unset until the end</returns>
function TBitArrayImplementation.getNextUnset(from: Integer): Integer;
var
bitsOffset,
currentBits: Integer;
begin
if (from >= Fsize) then
begin
Result := Fsize;
exit;
end;
bitsOffset := TMathUtils.Asr(from, 5);
currentBits := not Fbits[bitsOffset];
// mask off lesser bits first
{$OVERFLOWCHECKS OFF}
currentBits := currentBits and -(1 shl (from and $1F));
{$OVERFLOWCHECKS ON}
while (currentBits = 0) do
begin
Inc(bitsOffset);
if (bitsOffset = Length(Fbits)) then
begin
Result := Size;
exit;
end;
currentBits := not Fbits[bitsOffset];
end;
Result := (bitsOffset shl 5) + numberOfTrailingZeros(currentBits);
if (Result > Size)
then
Result := Size;
end;
procedure TBitArrayImplementation.InitLookup;
begin
_lookup := TArray<Integer>.Create(32, 0, 1, 26, 2, 23, 27, 0, 3, 16, 24, 30,
28, 11, 0, 13, 4, 7, 17, 0, 25, 22, 31, 15, 29, 10, 12, 6, 0, 21, 14, 9, 5,
20, 8, 19, 18);
end;
function TBitArrayImplementation.makeArray(Size: Integer): TArray<Integer>;
var
ar: TArray<Integer>;
begin
SetLength(ar, TMathUtils.Asr((Size + 31), 5));
Result := ar;
end;
function TBitArrayImplementation.numberOfTrailingZeros(num: Integer): Integer;
var
index: Integer;
begin
Result := 0;
{$OVERFLOWCHECKS OFF}
index := (-num and num) mod 37;
if (index < 0) then
begin
index := index * -1;
end;
if (index >= Low(_lookup)) and (index <= High(_lookup)) then
Result := _lookup[index];
{$OVERFLOWCHECKS ON}
end;
procedure TBitArrayImplementation.Reverse;
var
newBits: TArray<Integer>;
i, len, oldBitsLen, leftOffset, mask, nextInt, currentInt: Integer;
x: Int64;
begin
SetLength(newBits, Length(Fbits));
// reverse all int's first
len := TMathUtils.Asr((Size - 1), 5);
oldBitsLen := len + 1;
for i := 0 to oldBitsLen - 1 do
begin
x := Fbits[i];
x := (TMathUtils.Asr(x, 1) and $55555555) or ((x and $55555555) shl 1);
x := (TMathUtils.Asr(x, 2) and $33333333) or ((x and $33333333) shl 2);
x := (TMathUtils.Asr(x, 4) and $0F0F0F0F) or ((x and $0F0F0F0F) shl 4);
x := (TMathUtils.Asr(x, 8) and $00FF00FF) or ((x and $00FF00FF) shl 8);
x := (TMathUtils.Asr(x, 16) and $0000FFFF) or ((x and $0000FFFF) shl 16);
newBits[len - i] := integer(x) ;
end;
// now correct the int's if the bit size isn't a multiple of 32
if (Size <> oldBitsLen * 32) then
begin
leftOffset := oldBitsLen * 32 - Size;
mask := 1;
for i := 0 to 31 - leftOffset - 1 do
begin
mask := (mask shl 1) or 1;
end;
currentInt := TMathUtils.Asr(newBits[0], leftOffset) and mask;
for i := 1 to oldBitsLen - 1 do
begin
nextInt := newBits[i];
currentInt := currentInt or (nextInt shl (32 - leftOffset));
newBits[i - 1] := currentInt;
currentInt := TMathUtils.Asr(nextInt, leftOffset) and mask;
end;
newBits[oldBitsLen - 1] := currentInt;
end;
Fbits := newBits;
end;
procedure TBitArrayImplementation.SetBit(i: Integer; Value: Boolean);
var
index: Integer;
begin
if (Value) then
begin
index := TMathUtils.Asr(i, 5);
Fbits[index] := Fbits[index] or 1 shl (i and $1F);
end;
end;
function TBitArrayImplementation.Size: Integer;
begin
result := FSize;
end;
function TBitArrayImplementation.SizeInBytes: Integer;
begin
Result := TMathUtils.Asr(Size + 7, 3);
end;
/// <summary> Sets a block of 32 bits, starting at bit i.
///
/// </summary>
/// <param name="i">first bit to set
/// </param>
/// <param name="newBits">the new value of the next 32 bits. Note again that the least-significant bit
/// corresponds to bit i, the next-least-significant to i+1, and so on.
/// </param>
procedure TBitArrayImplementation.setBulk(i, newBits: Integer);
var
r: Integer;
begin
r := TMathUtils.Asr(i, 5);
Fbits[r] := newBits;
end;
/// <summary>
/// Sets a range of bits.
/// </summary>
/// <param name="start">start of range, inclusive.</param>
/// <param name="ending">end of range, exclusive</param>
procedure TBitArrayImplementation.setRange(start, ending: Integer);
var
firstInt,
lastInt,
mask,
i, j : Integer;
firstBit,
lastBit : Integer;
begin
if (ending < start)
then
raise EArgumentException.Create('Start is greater than end');
if (ending = start)
then
exit;
Dec(ending); // will be easier to treat this as the last actually set bit -- inclusive
firstInt := TMathUtils.Asr(start, 5);
lastInt := TMathUtils.Asr(ending, 5);
for i := firstInt to lastInt do
begin
if (i > firstInt)
then
firstBit := start
else
firstBit := $1F;
if (i < lastInt)
then
lastBit := 31
else
lastBit := (ending and $1F);
if ((firstBit = 0) and (lastBit = 31))
then
mask := -1
else
begin
mask := 0;
for j := firstBit to lastBit do
begin
mask := (mask or (1 shl j));
end;
end;
bits[i] := (bits[i] or mask);
end;
end;
/// <summary> Clears all bits (sets to false).</summary>
procedure TBitArrayImplementation.Clear;
var
max,
i: Integer;
begin
max := Length(Fbits);
for i := 0 to Pred(max) do
begin
Fbits[i] := 0;
end;
end;
/// <summary> Efficient method to check if a range of bits is set, or not set.
///
/// </summary>
/// <param name="start">start of range, inclusive.
/// </param>
/// <param name="ending">end of range, exclusive
/// </param>
/// <param name="value">if true, checks that bits in range are set, otherwise checks that they are not set
/// </param>
/// <returns> true iff all bits are set or not set in range, according to value argument
/// </returns>
/// <throws> EIllegalArgumentException if end is less than or equal to start </throws>
function TBitArrayImplementation.isRange(start, ending: Integer;
const value: Boolean): Boolean;
var
firstInt,
lastInt,
firstBit,
lastBit,
mask,
i, j,
temp: Integer;
begin
if (ending = start) then
begin
Result := true; // empty range matches
exit;
end;
Dec(ending); // will be easier to treat this as the last actually set bit -- inclusive
firstInt := TMathUtils.Asr(start, 5);
lastInt := TMathUtils.Asr(ending, 5);
for i := firstInt to lastInt do
begin
if (i > firstInt)
then
firstBit := 0
else
firstBit := (start and $1F);
if (i < lastInt)
then
lastBit := 31
else
lastBit := (ending and $1F);
if ((firstBit = 0) and (lastBit = 31))
then
mask := -1
else
begin
mask := 0;
for j := firstBit to lastBit do
mask := mask or (1 shl j);
end;
// Return false if we're looking for 1s and the masked bits[i] isn't all 1s (that is,
// equals the mask, or we're looking for 0s and the masked portion is not all 0s
if (Value)
then
temp := mask
else
temp := 0;
if ((Fbits[i] and mask) <> (temp)) then
begin
Result := False;
exit;
end;
end;
Result := true;
end;
/// <summary>
/// Appends the bit.
/// </summary>
/// <param name="bit">The bit.</param>
procedure TBitArrayImplementation.appendBit(bit: Boolean);
var
i: Integer;
begin
ensureCapacity(Fsize + 1);
if (bit) then
begin
i := TMathUtils.Asr(Fsize, 5);
bits[i] := (bits[i] or (Fsize and $1F));
end;
Dec(Fsize);
end;
function NewBitArray:IBitArray;
begin
result := TBitArrayImplementation.Create;
end;
function NewBitArray(const Size: Integer):IBitArray;
begin
result := TBitArrayImplementation.Create(size);
end;
end.
@@ -0,0 +1,480 @@
{
* Copyright 2008 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Original Authors: Sean Owen and dswitkin@google.com (Daniel Switkin)
* Delphi Implementation by E. Spelt and K. Gossens
}
unit ZXing.Common.BitMatrix;
interface
uses
SysUtils,
{$IFDEF FRAMEWORK_FMX}
FMX.Graphics,
{$ENDIF}
{$IFDEF FRAMEWORK_VCL}
VCL.Graphics,
{$ENDIF}
Generics.Collections,
ZXing.Common.BitArray,
ZXing.BarcodeFormat,
ZXing.Helpers,
ZXing.Common.Detector.MathUtils;
type
/// <summary>
/// <p>Represents a 2D matrix of bits. In function arguments below, and throughout the common
/// module, x is the column position, and y is the row position. The ordering is always x, y.
/// The origin is at the top-left.</p>
/// <p>Internally the bits are represented in a 1-D array of 32-bit ints. However, each row begins
/// with a new int. This is done intentionally so that we can copy out a row into a BitArray very
/// efficiently.</p>
/// <p>The ordering of bits is row-major. Within each int, the least significant bits are used first,
/// meaning they represent lower x values. This is compatible with BitArray's implementation.</p>
/// </summary>
TBitMatrix = class sealed
private
Fbits: TArray<Integer>;
Fheight: Integer;
FrowSize: Integer;
Fwidth: Integer;
function getBit(x, y: Integer): Boolean;
procedure setBit(x, y: Integer; const value: Boolean);
constructor Create(const width, height, rowSize: Integer;
const bits: TArray<Integer>); overload;
public
constructor Create(const width, height: Integer); overload;
constructor Create(const dimension: Integer); overload;
destructor Destroy; override;
procedure clear;
function Clone: TObject;
function Equals(obj: TObject): Boolean; override;
procedure flip(x: Integer; y: Integer);
function getBottomRightOnBit: TArray<Integer>;
function getEnclosingRectangle: TArray<Integer>;
function GetHashCode: Integer; override;
function getRow(const y: Integer; row: IBitArray): IBitArray;
function getTopLeftOnBit: TArray<Integer>;
procedure Rotate180;
procedure setRegion(left: Integer; top: Integer; width: Integer;
height: Integer);
procedure setRow(y: Integer; row: IBitArray);
function ToBitmap: TBitmap; overload;
function ToBitmap(format: TBarcodeFormat; content: string)
: TBitmap; overload;
property width: Integer read Fwidth;
property height: Integer read Fheight;
property Matrix[x, y: Integer]: Boolean read getBit write setBit; default;
// added for debugging
function ToString: string; override;
end;
implementation
{ TBitMatrix }
function TBitMatrix.getBit(x, y: Integer): Boolean;
var
offset, v, bits, shift: Int64;
uBits: Cardinal;
begin
offset := y * FrowSize + TMathUtils.Asr(x, 5);
if ( offset >= Low( FBits ) ) and ( offset <= High( FBits ) ) then
begin
bits := Fbits[offset];
uBits := Cardinal(bits);
shift := (x and $1F);
v := TMathUtils.Asr(uBits, shift);
Result := (v and 1) <> 0;
end
else
Result := False;
end;
procedure TBitMatrix.setBit(x, y: Integer; const value: Boolean);
var
offset: NativeInt;
begin
if (value) then
begin
offset := y * FrowSize + TMathUtils.Asr(x, 5);
Fbits[offset] := Fbits[offset] or (1 shl (x and $1F));
end
else
begin
offset := Trunc(y * FrowSize + (x / 32));
Fbits[offset] := Fbits[offset] and (not(1 shl (x and $1F)));
end;
end;
procedure TBitMatrix.clear;
var
max, i: Integer;
begin
max := Length(Fbits);
i := 0;
while ((i < max)) do
begin
Fbits[i] := 0;
Inc(i);
end;
end;
function TBitMatrix.Clone: TObject;
var
b: TArray<Integer>;
begin
b := TArray.Clone(Fbits);
Result := TBitMatrix.Create(Self.Fwidth, Self.Fheight, Self.FrowSize, b);
end;
constructor TBitMatrix.Create(const width, height, rowSize: Integer;
const bits: TArray<Integer>);
begin
if ((width < 1) or (height < 1)) then
raise EArgumentException.Create('Both dimensions must be greater than 0');
Self.Fwidth := width;
Self.Fheight := height;
Self.FrowSize := rowSize;
Self.Fbits := bits;
end;
constructor TBitMatrix.Create(const width, height: Integer);
begin
if ((width < 1) or (height < 1)) then
raise EArgumentException.Create('Both dimensions must be greater than 0');
Self.Fwidth := width;
Self.Fheight := height;
Self.FrowSize := TMathUtils.Asr((width + $1F), 5);
SetLength(Self.Fbits, Self.FrowSize * height);
Self.clear;
end;
constructor TBitMatrix.Create(const dimension: Integer);
begin
Self.Create(dimension, dimension);
end;
destructor TBitMatrix.Destroy;
begin
Self.Fbits := nil;
inherited;
end;
function TBitMatrix.Equals(obj: TObject): Boolean;
var
other: TBitMatrix;
i, l: Integer;
begin
if (not(obj is TBitMatrix)) then
begin
Result := false;
exit;
end;
other := (obj as TBitMatrix);
if ((((Fwidth <> other.Fwidth) or (Fheight <> other.Fheight)) or
(FrowSize <> other.FrowSize)) or (Length(Fbits) <> Length(other.Fbits)))
then
begin
Result := false;
exit
end;
i := 0;
l := Length(Fbits);
while ((i < l)) do
begin
if (Fbits[i] <> other.Fbits[i]) then
begin
Result := false;
exit
end;
Inc(i)
end;
Result := true;
end;
procedure TBitMatrix.flip(x, y: Integer);
var
offset, s: Integer;
begin
s := TMathUtils.Asr(x, 5);
offset := ((y * FrowSize) + s);
Fbits[offset] := (Fbits[offset] xor (1 shl x))
end;
function TBitMatrix.getBottomRightOnBit: TArray<Integer>;
var
bitsOffset, x, y, theBits, bit: Integer;
begin
bitsOffset := Length(Fbits) - 1;
while ((bitsOffset >= 0) and (Self.Fbits[bitsOffset] = 0)) do
begin
dec(bitsOffset)
end;
if (bitsOffset < 0) then
begin
Result := nil;
exit
end;
y := (bitsOffset div FrowSize);
x := ((bitsOffset mod FrowSize) shl 5);
theBits := Fbits[bitsOffset];
bit := $1F;
while ((TMathUtils.Asr(theBits, bit) = 0)) do
begin
dec(bit);
end;
Inc(x, bit);
Result := TArray<Integer>.Create(x, y);
end;
function TBitMatrix.getEnclosingRectangle: TArray<Integer>;
var
bit, left, top, right, bottom, y, x32, theBits, widthTmp, heightTmp: Integer;
begin
left := Self.Fwidth;
top := Self.Fheight;
right := -1;
bottom := -1;
y := 0;
while ((y < Self.Fheight)) do
begin
x32 := 0;
while ((x32 < Self.FrowSize)) do
begin
theBits := Self.Fbits[((y * Self.FrowSize) + x32)];
if (theBits <> 0) then
begin
if (y < top) then
top := y;
if (y > bottom) then
bottom := y;
if ((x32 * $20) < left) then
begin
bit := 0;
while (((theBits shl ($1F - bit)) = 0)) do
begin
Inc(bit)
end;
if (((x32 * $20) + bit) < left) then
left := ((x32 * $20) + bit)
end;
if (((x32 * $20) + $1F) > right) then
begin
bit := $1F;
while ((TMathUtils.Asr(theBits, bit) = 0)) do
begin
dec(bit)
end;
if (((x32 * $20) + bit) > right) then
right := ((x32 * $20) + bit)
end
end;
Inc(x32)
end;
Inc(y)
end;
widthTmp := (right - left);
heightTmp := (bottom - top);
if ((widthTmp < 0) or (heightTmp < 0)) then
begin
Result := nil;
exit;
end;
Result := TArray<Integer>.Create(left, top, widthTmp, heightTmp);
end;
function TBitMatrix.GetHashCode: Integer;
var
bit, hash: Integer;
begin
hash := Self.Fwidth;
hash := (($1F * hash) + Self.Fwidth);
hash := (($1F * hash) + Self.Fheight);
hash := (($1F * hash) + Self.FrowSize);
for bit in Self.Fbits do
begin
hash := (($1F * hash) + bit); // .GetHashCode
end;
Result := hash;
end;
function TBitMatrix.getRow(const y: Integer; row: IBitArray): IBitArray;
var
x, offset: Integer;
begin
if ((row = nil) or (row.Size < Self.Fwidth)) then
row := TBitArrayHelpers.CreateBitArray(Self.Fwidth)
else
row.clear;
offset := (y * Self.FrowSize);
x := 0;
while ((x < Self.FrowSize)) do
begin
row.setBulk((x shl 5), Self.Fbits[(offset + x)]);
Inc(x)
end;
Result := row;
end;
function TBitMatrix.getTopLeftOnBit: TArray<Integer>;
var
bitsOffset, x, y, theBits, bit: Integer;
begin
bitsOffset := 0;
while (((bitsOffset < Length(Fbits)) and (Fbits[bitsOffset] = 0))) do
begin
Inc(bitsOffset)
end;
if (bitsOffset = Length(Fbits)) then
begin
Result := nil;
exit
end;
y := (bitsOffset div Self.FrowSize);
x := ((bitsOffset mod Self.FrowSize) shl 5);
theBits := Self.Fbits[bitsOffset];
bit := 0;
while (((theBits shl ($1F - bit)) = 0)) do
begin
Inc(bit)
end;
Inc(x, bit);
Result := TArray<Integer>.Create(x, y);
end;
procedure TBitMatrix.Rotate180;
var
i, width, height: Integer;
topRow, bottomRow: IBitArray;
begin
width := Self.Fwidth;
height := Self.Fheight;
topRow := TBitArrayHelpers.CreateBitArray(width);
bottomRow := TBitArrayHelpers.CreateBitArray(width);
i := 0;
while ((i < ((height + 1) div 2))) do
begin
topRow := Self.getRow(i, topRow);
bottomRow := Self.getRow(((height - 1) - i), bottomRow);
topRow.reverse;
bottomRow.reverse;
Self.setRow(i, bottomRow);
Self.setRow(((height - 1) - i), topRow);
Inc(i)
end;
end;
procedure TBitMatrix.setRegion(left, top, width, height: Integer);
var
x, y, offset, right, bottom: Integer;
begin
if ((top < 0) or (left < 0)) then
raise EArgumentException.Create('Left and top must be non-negative');
if ((height < 1) or (width < 1)) then
raise EArgumentException.Create('Height and width must be at least 1');
right := (left + width);
bottom := (top + height);
if ((bottom > Self.Fheight) or (right > Self.Fwidth)) then
raise EArgumentException.Create('The region must fit inside the matrix');
y := top;
while ((y < bottom)) do
begin
offset := (y * Self.FrowSize);
x := left;
while ((x < right)) do
begin
Fbits[(offset + TMathUtils.Asr(x, 5))] :=
(Fbits[(offset + TMathUtils.Asr(x, 5))] or (1 shl x));
Inc(x)
end;
Inc(y)
end;
end;
procedure TBitMatrix.setRow(y: Integer; row: IBitArray);
begin
Fbits := System.Copy(row.bits, (y * FrowSize), FrowSize);
end;
function TBitMatrix.ToBitmap(format: TBarcodeFormat; content: string): TBitmap;
begin
raise ENotImplemented.Create('Converting to bitmap is not implemented yet!');
end;
function TBitMatrix.ToString: string;
var
r, c: Integer;
begin
for r := 0 to Fheight - 1 do
begin
for c := 0 to Fwidth - 1 do
begin
if Matrix[r, c] then
Result := Result + '*'
else
Result := Result + '.';
end;
Result := Result + #13#10;
end;
end;
function TBitMatrix.ToBitmap: TBitmap;
begin
Result := ToBitmap(TBarcodeFormat.CODE_128, '')
end;
end.
@@ -0,0 +1,63 @@
{
* Copyright 2007 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Original Author: Sean Owen
* Ported from ZXING Java Source: www.Redivivus.in (suraj.supekar@redivivus.in)
* Delphi Implementation by E. Spelt and K. Gossens
}
unit ZXing.Common.DetectorResult;
interface
uses
System.SysUtils,
ZXing.Common.BitMatrix,
ZXing.ResultPoint;
type
/// <summary> <p>Encapsulates the result of detecting a barcode in an image. This includes the raw
/// matrix of black/white pixels corresponding to the barcode, and possibly points of interest
/// in the image, like the location of finder patterns or corners of the barcode in the image.</p>
/// </summary>
TDetectorResult = class
private
Fbits: TBitmatrix;
Fpoints: TArray<IResultPoint>;
public
constructor Create(const bits: TBitmatrix; const points: TArray<IResultPoint>);
destructor Destroy; override;
property bits: TBitmatrix read Fbits;
property points: TArray<IResultPoint> read Fpoints;
end;
implementation
constructor TDetectorResult.Create(const bits: TBitmatrix;
const points: TArray<IResultPoint>);
begin
Fbits := bits;
Fpoints := points;
end;
destructor TDetectorResult.Destroy;
begin
FPoints := nil;
FBits.Free;
inherited;
end;
end.
@@ -0,0 +1,159 @@
{
* Copyright 2008 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Implemented by K. Gossens for Delphi
}
unit ZXing.Common.GridSampler;
interface
uses
System.SysUtils,
ZXing.Common.Bitmatrix,
ZXing.Common.PerspectiveTransform;
type
TGridSampler = class abstract
private
class var FgridSampler: TGridSampler;
//class constructor Create;
protected
constructor Create;
class function checkAndNudgePoints(image: TBitMatrix; points: TArray<Single>): boolean; static;
public
function sampleGrid(image: TBitMatrix; dimensionX: Integer;
dimensionY: Integer; transform: TPerspectiveTransform): TBitMatrix; overload; virtual;
function sampleGrid(image: TBitMatrix; dimensionX: Integer;
dimensionY: Integer; p1ToX: Single; p1ToY: Single; p2ToX: Single;
p2ToY: Single; p3ToX: Single; p3ToY: Single; p4ToX: Single; p4ToY: Single;
p1FromX: Single; p1FromY: Single; p2FromX: Single; p2FromY: Single;
p3FromX: Single; p3FromY: Single; p4FromX: Single; p4FromY: Single): TBitMatrix; overload; virtual; abstract;
procedure setGridSampler(newGridSampler: TGridSampler); //static;
class property Instance: TGridSampler read FgridSampler;
end;
implementation
{ TGridSampler }
constructor TGridSampler.Create;
begin
inherited Create;
end;
class function TGridSampler.checkAndNudgePoints(image: TBitMatrix;
points: TArray<Single>): boolean;
var
width,
height : Integer;
nudged : Boolean;
offset, maxOffset : Integer;
x, y : Single;
begin
width := image.Width;
height := image.Height;
nudged := true;
offset := 0;
maxOffset := Length(points) - 1; // points.length must be even
while ((offset < maxOffset) and nudged) do
begin
x := points[offset];
y := points[(offset + 1)];
if (((x < -1) or (x > width)) or ((y < -1) or (y > height))) then
begin
Result := false;
exit;
end;
nudged := false;
if (x = -1) then
begin
points[offset] := 0;
nudged := true;
end
else
if (x = width) then
begin
points[offset] := (width - 1);
nudged := true;
end;
if (y = -1) then
begin
points[(offset + 1)] := 0;
nudged := true;
end
else
if (y = height) then
begin
points[(offset + 1)] := (height - 1);
nudged := true;
end;
Inc(offset, 2)
end;
nudged := true;
offset := (Length(points) - 2);
while (((offset >= 0) and nudged)) do
begin
x := points[offset];
y := points[(offset + 1)];
if (((x < -1) or (x > width)) or ((y < -1) or (y > height))) then
begin
Result := false;
exit;
end;
nudged := false;
if (x = -1) then
begin
points[offset] := 0;
nudged := true;
end else
if (x = width) then
begin
points[offset] := (width - 1);
nudged := true;
end;
if (y = -1) then
begin
points[(offset + 1)] := 0;
nudged := true
end else
if (y = height) then
begin
points[(offset + 1)] := (height - 1);
nudged := true;
end;
dec(offset, 2)
end;
Result := true;
end;
function TGridSampler.sampleGrid(image: TBitMatrix; dimensionX: Integer;
dimensionY: Integer; transform: TPerspectiveTransform): TBitMatrix;
begin
raise ENotSupportedException.Create('Not yet supported');
end;
procedure TGridSampler.setGridSampler(newGridSampler: TGridSampler);
begin
if (newGridSampler = nil)
then
raise EArgumentException.Create('Missing arguments');
FgridSampler := newGridSampler;
end;
end.
@@ -0,0 +1,248 @@
{
* Copyright 2007 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Original Author: Sean Owen
* Ported from ZXING Java Source: www.Redivivus.in (suraj.supekar@redivivus.in)
* Delphi Implementation by E. Spelt and K. Gossens
}
unit ZXing.Common.PerspectiveTransform;
interface
uses
System.SysUtils;
type
/// <summary> <p>This class implements a perspective transform in two dimensions. Given four source and four
/// destination points, it will compute the transformation implied between them. The code is based
/// directly upon section 3.4.2 of George Wolberg's "Digital Image Warping"; see pages 54-56.</p>
/// </summary>
TPerspectiveTransform = class sealed
private
a11: Single;
a12: Single;
a13: Single;
a21: Single;
a22: Single;
a23: Single;
a31: Single;
a32: Single;
a33: Single;
function buildAdjoint(): TPerspectiveTransform;
function times(const other: TPerspectiveTransform): TPerspectiveTransform;
public
constructor Create(const a11, a21, a31, a12, a22, a32, a13,
a23, a33: Single);
class function quadrilateralToQuadrilateral(const x0, y0, x1, y1, x2, y2,
x3, y3, x0p, y0p, x1p, y1p, x2p, y2p,
x3p, y3p: Single): TPerspectiveTransform; static;
class function quadrilateralToSquare(x0: Single; y0: Single; x1: Single;
y1: Single; x2: Single; y2: Single; x3: Single; y3: Single)
: TPerspectiveTransform; static;
class function squareToQuadrilateral(const x0, y0, x1, y1, x2, y2,
x3, y3: Single): TPerspectiveTransform; static;
procedure transformPoints(var points: TArray<Single>); overload;
/// <summary>Convenience method, not optimized for performance. </summary>
procedure transformPoints(const xValues, yValues: TArray<Single>); overload;
end;
implementation
constructor TPerspectiveTransform.Create(const a11, a21, a31, a12, a22, a32,
a13, a23, a33: Single);
begin
Self.a11 := a11;
Self.a12 := a12;
Self.a13 := a13;
Self.a21 := a21;
Self.a22 := a22;
Self.a23 := a23;
Self.a31 := a31;
Self.a32 := a32;
Self.a33 := a33;
end;
class function TPerspectiveTransform.quadrilateralToQuadrilateral(const x0, y0,
x1, y1, x2, y2, x3, y3, x0p, y0p, x1p, y1p, x2p, y2p,
x3p, y3p: Single): TPerspectiveTransform;
var
qToS,
SToQ : TPerspectiveTransform;
begin
qToS := nil;
SToQ := nil;
try
qToS := TPerspectiveTransform.quadrilateralToSquare(x0, y0, x1, y1, x2,
y2, x3, y3);
SToQ := TPerspectiveTransform.squareToQuadrilateral(x0p, y0p, x1p, y1p, x2p,
y2p, x3p, y3p);
Result := SToQ.times(qToS);
finally
//if (SToQ <> nil)
//then
SToQ.Free;
//if (qToS <> nil)
//then
qToS.Free;
end;
end;
class function TPerspectiveTransform.quadrilateralToSquare(x0: Single;
y0: Single; x1: Single; y1: Single; x2: Single; y2: Single; x3: Single;
y3: Single): TPerspectiveTransform;
var
SToQ: TPerspectiveTransform;
begin
SToQ := nil;
// Here, the adjoint serves as the inverse:
try
SToQ := TPerspectiveTransform.squareToQuadrilateral(x0, y0, x1, y1, x2,
y2, x3, y3);
Result := SToQ.buildAdjoint;
finally
//if (SToQ <> nil)
//then
SToQ.Free;
end;
end;
class function TPerspectiveTransform.squareToQuadrilateral(const x0, y0,
x1, y1, x2, y2, x3, y3: Single): TPerspectiveTransform;
var
dx1, dx2,
dx3, dy1,
dy2, dy3,
a13, a23,
denominator: Single;
begin
dx3 := (((x0 - x1) + x2) - x3);
dy3 := (((y0 - y1) + y2) - y3);
if ((dx3 = 0) and (dy3 = 0)) then
begin
Result := TPerspectiveTransform.Create((x1 - x0), (x2 - x1), x0, (y1 - y0),
(y2 - y1), y0, 0, 0, 1);
end else
begin
dx1 := (x1 - x2);
dx2 := (x3 - x2);
dy1 := (y1 - y2);
dy2 := (y3 - y2);
denominator := ((dx1 * dy2) - (dx2 * dy1));
if denominator = 0 then
begin
a13 := 0;
a23 := 0;
end
else
begin
a13 := (((dx3 * dy2) - (dx2 * dy3)) / denominator);
a23 := (((dx1 * dy3) - (dx3 * dy1)) / denominator);
end;
Result := TPerspectiveTransform.Create(((x1 - x0) + (a13 * x1)),
((x3 - x0) + (a23 * x3)), x0, ((y1 - y0) + (a13 * y1)),
((y3 - y0) + (a23 * y3)), y0, a13, a23, 1);
end;
end;
procedure TPerspectiveTransform.transformPoints(var points: TArray<Single>);
var
max, i: Integer;
x, y,
denominator: Single;
begin
a11 := Self.a11;
a12 := Self.a12;
a13 := Self.a13;
a21 := Self.a21;
a22 := Self.a22;
a23 := Self.a23;
a31 := Self.a31;
a32 := Self.a32;
a33 := Self.a33;
i := 0;
max := Length(points) - 1;
while ((i < max)) do
begin
x := points[i];
y := points[(i + 1)];
denominator := (((a13 * x) + (a23 * y)) + a33);
points[i] := ((((a11 * x) + (a21 * y)) + a31) / denominator);
points[(i + 1)] := ((((a12 * x) + (a22 * y)) + a32) / denominator);
Inc(i, 2);
end
end;
procedure TPerspectiveTransform.transformPoints(const xValues,
yValues: TArray<Single>);
var
n, i: Integer;
x, y, denominator: Single;
begin
n := Length(xValues);
for i := 0 to Pred(n) do
begin
x := xValues[i];
y := yValues[i];
denominator := (((self.a13 * x) + (self.a23 * y)) + self.a33);
xValues[i] := ((((self.a11 * x) + (self.a21 * y)) + self.a31) /
denominator);
yValues[i] := ((((self.a12 * x) + (self.a22 * y)) + self.a32) /
denominator);
end
end;
function TPerspectiveTransform.buildAdjoint(): TPerspectiveTransform;
begin
// Adjoint is the transpose of the cofactor matrix:
Result := TPerspectiveTransform.Create(a22 * a33 - a23 * a32,
a23 * a31 - a21 * a33,
a21 * a32 - a22 * a31,
a13 * a32 - a12 * a33,
a11 * a33 - a13 * a31,
a12 * a31 - a11 * a32,
a12 * a23 - a13 * a22,
a13 * a21 - a11 * a23,
a11 * a22 - a12 * a21);
end;
function TPerspectiveTransform.times(
const other: TPerspectiveTransform): TPerspectiveTransform;
begin
Result := TPerspectiveTransform.Create(a11 * other.a11 + a21 * other.a12 + a31 * other.a13,
a11 * other.a21 + a21 * other.a22 + a31 * other.a23,
a11 * other.a31 + a21 * other.a32 + a31 * other.a33,
a12 * other.a11 + a22 * other.a12 + a32 * other.a13,
a12 * other.a21 + a22 * other.a22 + a32 * other.a23,
a12 * other.a31 + a22 * other.a32 + a32 * other.a33,
a13 * other.a11 + a23 * other.a12 + a33 * other.a13,
a13 * other.a21 + a23 * other.a22 + a33 * other.a23,
a13 * other.a31 + a23 * other.a32 + a33 * other.a33);
end;
end.
@@ -0,0 +1,127 @@
{
* Copyright 2008 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Implemented by E. Spelt for Delphi
* Restructured by K. Gossens
}
unit ZXing.DecodeHintType;
interface
type
TDecodeHintType = (
/// <summary>
/// Unspecified, application-specific hint. Maps to an unspecified <see cref="System.Object" />.
/// </summary>
OTHER,
/// <summary>
/// Image is a pure monochrome image of a barcode. Doesn't matter what it maps to;
/// use <see cref="bool" /> = true.
/// </summary>
PURE_BARCODE,
/// <summary>
/// Image is known to be of one of a few possible formats.
/// Maps to a <see cref="System.Collections.ICollection" /> of <see cref="BarcodeFormat" />s.
/// </summary>
POSSIBLE_FORMATS,
/// <summary>
/// Spend more time to try to find a barcode; optimize for accuracy, not speed.
/// Doesn't matter what it maps to; use <see cref="bool" /> = true.
/// </summary>
TRY_HARDER,
/// <summary>
/// Specifies what character encoding to use when decoding, where applicable (type String)
/// </summary>
CHARACTER_SET,
/// <summary>
/// Allowed lengths of encoded data -- reject anything else. Maps to an int[].
/// </summary>
ALLOWED_LENGTHS,
/// <summary>
/// Assume Code 39 codes employ a check digit. Maps to <see cref="bool" />.
/// </summary>
ASSUME_CODE_39_CHECK_DIGIT,
/// <summary>
/// The caller needs to be notified via callback when a possible <see cref="TResultPoint" />
/// is found. Maps to a <see cref="TResultPointCallback" />.
/// </summary>
NEED_RESULT_POINT_CALLBACK,
/// <summary>
/// Assume MSI codes employ a check digit. Maps to <see cref="bool" />.
/// </summary>
ASSUME_MSI_CHECK_DIGIT,
/// <summary>
/// if Code39 could be detected try to use extended mode for full ASCII character set
/// Maps to <see cref="bool" />.
/// </summary>
USE_CODE_39_EXTENDED_MODE,
/// <summary>
/// Don't fail if a Code39 is detected but can't be decoded in extended mode.
/// Return the raw Code39 result instead. Maps to <see cref="bool" />.
/// </summary>
RELAXED_CODE_39_EXTENDED_MODE,
/// <summary>
/// 1D readers supporting rotation with TRY_HARDER enabled.
/// But BarcodeReader class can do auto-rotating for 1D and 2D codes.
/// Enabling that option prevents 1D readers doing double rotation.
/// BarcodeReader enables that option automatically if "global" auto-rotation is enabled.
/// Maps to <see cref="bool" />.
/// </summary>
TRY_HARDER_WITHOUT_ROTATION,
/// <summary>
/// Assume the barcode is being processed as a GS1 barcode, and modify behavior as needed.
/// For example this affects FNC1 handling for Code 128 (aka GS1-128). Doesn't matter what it maps to;
/// use <see cref="bool" />.
/// </summary>
ASSUME_GS1,
/// <summary>
/// If true, return the start and end digits in a Codabar barcode instead of stripping them. They
/// are alpha, whereas the rest are numeric. By default, they are stripped, but this causes them
/// to not be. Doesn't matter what it maps to; use <see cref="bool" />.
/// </summary>
RETURN_CODABAR_START_END,
/// <summary>
/// Allowed extension lengths for EAN or UPC barcodes. Other formats will ignore this.
/// Maps to an <see cref="Array.int" /> of the allowed extension lengths, for example [2], [5], or [2, 5].
/// If it is optional to have an extension, do not set this hint. If this is set,
/// and a UPC or EAN barcode is found but an extension is not, then no result will be returned
/// at all.
/// </summary>
ALLOWED_EAN_EXTENSIONS,
/// <summary>
/// Allowes for inversion of an image.
/// Add the to invert the image
/// </summary>
ENABLE_INVERSION
);
implementation
end.
@@ -0,0 +1,90 @@
unit ZXing.DecoderResult;
{
* Copyright 2008 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Implemented by E. Spelt for Delphi
}
interface
uses SysUtils,
Generics.Collections,
ZXIng.ByteSegments;
type
TDecoderResult = class
private
function GetStructuredAppend: boolean;
public
ByteSegments: IByteSegments;
ECLevel: string;
Erasures: Integer;
ErrorsCorrected: Integer;
Other: TObject;
RawBytes: TArray<Byte>;
StructuredAppendParity: Integer;
StructuredAppendSequenceNumber: Integer;
Text: string;
constructor Create(RawBytes: TArray<Byte>; const Text: string;
ByteSegments: IByteSegments; ECLevel: string); overload;
constructor Create(RawBytes: TArray<Byte>; const Text: string;
ByteSegments: IByteSegments; ECLevel: string; saSequence: Integer;
saParity: Integer); overload;
destructor Destroy; override;
property StructuredAppend: boolean read GetStructuredAppend;
end;
implementation
{ TDecoderResult }
constructor TDecoderResult.Create(RawBytes: TArray<Byte>; const Text: String;
ByteSegments: IByteSegments; ECLevel: String);
begin
Self.Create(RawBytes, Text, ByteSegments, ECLevel, -1, -1);
end;
constructor TDecoderResult.Create(RawBytes: TArray<Byte>; const Text: string;
ByteSegments: IByteSegments; ECLevel: string;
saSequence, saParity: Integer);
begin
if ((RawBytes = nil) and (Text = ''))
then
raise EArgumentException.Create('Text or rawbytes cannot be nil or empty');
Self.RawBytes := RawBytes;
Self.Text := Text;
Self.ByteSegments := ByteSegments;
Self.ECLevel := ECLevel;
Self.StructuredAppendParity := saParity;
Self.StructuredAppendSequenceNumber := saSequence
end;
destructor TDecoderResult.Destroy;
begin
RawBytes := nil;
FreeAndNil(Other);
inherited;
end;
function TDecoderResult.GetStructuredAppend: boolean;
begin
result := (StructuredAppendParity >= 0) and
(StructuredAppendSequenceNumber >= 0);
end;
end.
@@ -0,0 +1,266 @@
{
* Copyright 2007 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Original Author: Sean Owen
* Ported from ZXING Java Source: www.Redivivus.in (suraj.supekar@redivivus.in)
* Delphi Implementation by E. Spelt and K. Gossens
}
unit ZXing.DefaultGridSampler;
interface
uses
System.SysUtils,
System.Math,
ZXing.Common.BitMatrix,
ZXing.Common.PerspectiveTransform,
ZXing.Common.Detector.MathUtils;
type
// TODO(KG) Add GridSampler basis class
TDefaultGridSampler = class //(TGridSampler)
private
class var GridSampler: TDefaultGridSampler;
class function get_Instance(): TDefaultGridSampler; static;
protected
/// <summary> <p>Checks a set of points that have been transformed to sample points on an image against
/// the image's dimensions to see if the point are even within the image.</p>
///
/// <p>This method will actually "nudge" the endpoints back onto the image if they are found to be
/// barely (less than 1 pixel) off the image. This accounts for imperfect detection of finder
/// patterns in an image where the QR Code runs all the way to the image border.</p>
///
/// <p>For efficiency, the method will check points from either end of the line until one is found
/// to be within the image. Because the set of points are assumed to be linear, this is valid.</p>
///
/// </summary>
/// <param name="image">image into which the points should map
/// </param>
/// <param name="points">actual points in x1,y1,...,xn,yn form
/// </param>
class function checkAndNudgePoints(const image: TBitMatrix;
const points: TArray<Single>): boolean; static;
public
class function sampleGrid(const image: TBitMatrix;
const dimensionX, dimensionY: Integer;
const p1ToX, p1ToY, p2ToX, p2ToY, p3ToX, p3ToY, p4ToX, p4ToY,
p1FromX, p1FromY, p2FromX, p2FromY, p3FromX, p3FromY, p4FromX,
p4FromY: Single): TBitMatrix; overload; static;
class function sampleGrid(const image: TBitMatrix;
const dimensionX, dimensionY: Integer;
const transform: TPerspectiveTransform): TBitMatrix; overload; static;
class procedure setGridSampler(newGridSampler: TDefaultGridSampler); static;
// Properties
class property Instance: TDefaultGridSampler read get_Instance;
end;
implementation
{ TDefaultGridSampler }
class function TDefaultGridSampler.sampleGrid(const image: TBitMatrix;
const dimensionX, dimensionY: Integer; const p1ToX, p1ToY, p2ToX, p2ToY,
p3ToX, p3ToY, p4ToX, p4ToY, p1FromX, p1FromY, p2FromX, p2FromY, p3FromX,
p3FromY, p4FromX, p4FromY: Single): TBitMatrix;
var
transform: TPerspectiveTransform;
begin
transform := TPerspectiveTransform.quadrilateralToQuadrilateral(p1ToX, p1ToY,
p2ToX, p2ToY, p3ToX, p3ToY, p4ToX, p4ToY, p1FromX, p1FromY, p2FromX,
p2FromY, p3FromX, p3FromY, p4FromX, p4FromY);
try
Result := sampleGrid(image, dimensionX, dimensionY, transform);
finally
transform.free;
end;
end;
class function TDefaultGridSampler.sampleGrid(const image: TBitMatrix;
const dimensionX, dimensionY: Integer;
const transform: TPerspectiveTransform) : TBitMatrix;
var
bits: TBitMatrix;
points: TArray<Single>;
y, x, max: Integer;
iValue: Single;
begin
Result := nil;
if ((dimensionX <= 0) or
(dimensionY <= 0))
then
exit;
bits := TBitMatrix.Create(dimensionX, dimensionY);
points := TArray<Single>.Create();
SetLength(points, dimensionX shl 1);
try
for y := 0 to Pred(dimensionY) do
begin
max := Length(points) - 1;
iValue := (y + 0.5);
x := 0;
while ((x < max)) do
begin
points[x] := TMathUtils.Asr(x, 1) + 0.5;
points[(x + 1)] := iValue;
Inc(x, 2);
end;
transform.transformPoints(points);
// Quick check to see if points transformed to something inside the image;
// sufficient to check the endpoints
if (not checkAndNudgePoints(image, points)) then
begin
bits.Free;
exit;
end;
try
x := 0;
while (x < max) do
begin
bits[(TMathUtils.Asr(x, 1)), y] := image[Floor(points[x]), Floor(points[x + 1])];
Inc(x, 2);
end
except
// This feels wrong, but, sometimes if the finder patterns are misidentified, the resulting
// transform gets "twisted" such that it maps a straight line of points to a set of points
// whose endpoints are in bounds, but others are not. There is probably some mathematical
// way to detect this about the transformation that I don't know yet.
// This results in an ugly runtime exception despite our clever checks above -- can't have
// that. We could check each point's coordinates but that feels duplicative. We settle for
// catching and wrapping ArrayIndexOutOfBoundsException.
exit;
end;
end;
finally
points := nil;
end;
Result := bits;
end;
class function TDefaultGridSampler.checkAndNudgePoints(const image: TBitMatrix;
const points: TArray<Single>): Boolean;
var
offset,
x, y,
width, height : Integer;
nudged : Boolean;
begin
width := image.width;
height := image.height;
// Check and nudge points from start until we see some that are OK:
nudged := true;
offset := 0;
while ((offset < (Length(points) - 1)) and nudged) do
begin
x := Floor(points[offset]);
y := Floor(points[(offset + 1)]);
if ((((x < -1) or (x > width)) or (y < -1)) or (y > height)) then
begin
Result := false;
exit
end;
nudged := false;
if (x = -1) then
begin
points[offset] := 0;
nudged := true
end
else if (x = width) then
begin
points[offset] := (width - 1);
nudged := true
end;
if (y = -1) then
begin
points[(offset + 1)] := 0;
nudged := true
end
else if (y = height) then
begin
points[(offset + 1)] := (height - 1);
nudged := true
end;
inc(offset, 2)
end;
// Check and nudge points from end:
nudged := true;
offset := (Length(points) - 2);
while ((offset >= 0) and nudged) do
begin
x := Floor(points[offset]);
y := Floor(points[(offset + 1)]);
if ((((x < -1) or (x > width)) or (y < -1)) or (y > height)) then
begin
Result := false;
exit
end;
nudged := false;
if (x = -1) then
begin
points[offset] := 0;
nudged := true
end
else if (x = width) then
begin
points[offset] := (width - 1);
nudged := true
end;
if (y = -1) then
begin
points[(offset + 1)] := 0;
nudged := true
end
else if (y = height) then
begin
points[(offset + 1)] := (height - 1);
nudged := true
end;
Dec(offset, 2);
end;
Result := true;
end;
class function TDefaultGridSampler.get_Instance: TDefaultGridSampler;
begin
GridSampler := TDefaultGridSampler.Create();
Result := GridSampler;
end;
class procedure TDefaultGridSampler.setGridSampler(newGridSampler
: TDefaultGridSampler);
begin
if (newGridSampler = nil) then
begin
raise EArgumentException.Create('Arguments in error');
end;
GridSampler := newGridSampler;
end;
end.
@@ -0,0 +1,43 @@
{
* Copyright 2008 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Implemented by E. Spelt for Delphi
* Restructured by K. Gossens
}
unit ZXing.EncodeHintType;
interface
type
TEncodeHintType = (AZTEC_LAYERS = 15,
CHARACTER_SET = 4,
CODE128_FORCE_CODESET_B = 13,
DATA_MATRIX_DEFAULT_ENCODATION = 14,
DATA_MATRIX_SHAPE = 10,
DISABLE_ECI = 9,
ERROR_CORRECTION = 3,
HEIGHT = 1,
MARGIN = 5,
MAX_SIZE = 12,
MIN_SIZE = 11,
PDF417_COMPACTION = 7,
PDF417_DIMENSIONS = 8,
PURE_BARCODE = 2,
WIDTH = 0);
implementation
end.
@@ -0,0 +1,62 @@
unit ZXing.Helpers;
{
* Copyright 2008 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Implemented by E. Spelt for Delphi
}
interface
type
TArray = class
class function Clone(original: TArray<Integer>): TArray<Integer>; static;
class function CopyInSameArray(const Input: TArray<Integer>;
StartIndex: Integer; Len: Integer): TArray<Integer>; static;
end;
implementation
class function TArray.Clone(original: TArray<Integer>): TArray<Integer>;
var
i: Integer;
l: SmallInt;
begin
l := Length(original);
Result := TArray<Integer>.Create();
SetLength(Result, l);
for i := 0 to l - 1 do
begin
Result[i] := original[i];
end;
end;
class function TArray.CopyInSameArray(const Input: TArray<Integer>;
StartIndex: Integer; Len: Integer): TArray<Integer>;
var
i, y: Integer;
begin
Result := TArray.Clone(Input);
y := 0;
for i := StartIndex to (StartIndex + Len -1) do
begin
Result[y] := Input[i];
inc(y);
end;
end;
end.
@@ -0,0 +1,350 @@
{
* Copyright 2007 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Original Authors: Sean Owen and dswitkin@google.com (Daniel Switkin)
* Ported from ZXING Java Source: www.Redivivus.in (suraj.supekar@redivivus.in)
* Delphi Implementation by E. Spelt and K. Gossens
}
unit ZXing.MultiFormatReader;
interface
uses
System.SysUtils,
System.Rtti,
System.Generics.Collections,
System.RegularExpressions,
ZXing.ReadResult,
ZXing.Reader,
ZXing.DecodeHintType,
ZXing.BinaryBitmap,
ZXing.BarcodeFormat,
ZXing.ResultPoint,
// 1D Barcodes
ZXing.OneD.OneDReader,
ZXing.OneD.Code128Reader,
ZXing.OneD.Code93Reader,
ZXing.OneD.ITFReader,
ZXing.OneD.EAN13Reader,
ZXing.OneD.EAN8Reader,
ZXing.OneD.UPCAReader,
ZXing.OneD.UPCEReader,
ZXing.OneD.Code39Reader,
// 2D Codes
ZXing.QrCode.QRCodeReader,
ZXing.Datamatrix.DataMatrixReader;
/// <summary>
/// MultiFormatReader is a convenience class and the main entry point into the library for most uses.
/// By default it attempts to decode all barcode formats that the library supports. Optionally, you
/// can provide a hints object to request different behavior, for example only decoding QR codes.
/// </summary>
/// <author>Sean Owen</author>
/// <author>dswitkin@google.com (Daniel Switkin)</author>
/// <author>www.Redivivus.in (suraj.supekar@redivivus.in) - Ported from ZXING Java Source</author>
type
TMultiFormatReader = class(TInterfacedObject, IReader)
private
FHints: TDictionary<TDecodeHintType, TObject>;
readers: TList<IReader>;
function DecodeInternal(image: TBinaryBitmap): TReadResult;
procedure Set_Hints(const Value: TDictionary<TDecodeHintType, TObject>);
function Get_Hints: TDictionary<TDecodeHintType, TObject>;
/// <summary> This version of decode honors the intent of Reader.decode(BinaryBitmap) in that it
/// passes null as a hint to the decoders. However, that makes it inefficient to call repeatedly.
/// Use setHints() followed by decodeWithState() for continuous scan applications.
///
/// </summary>
/// <param name="image">The pixel data to decode
/// </param>
/// <returns> The contents of the image
/// </returns>
/// <throws> ReaderException Any errors which occurred </throws>
public
function decode(const image: TBinaryBitmap): TReadResult; overload;
function decode(const image: TBinaryBitmap; WithHints: Boolean)
: TReadResult; overload;
/// <summary> Decode an image using the hints provided. Does not honor existing state.
///
/// </summary>
/// <param name="image">The pixel data to decode
/// </param>
/// <param name="hints">The hints to use, clearing the previous state.
/// </param>
/// <returns> The contents of the image
/// </returns>
/// <throws> ReaderException Any errors which occurred </throws>
function decode(const image: TBinaryBitmap;
hints: TDictionary<TDecodeHintType, TObject>): TReadResult; overload;
/// <summary> Decode an image using the state set up by calling setHints() previously. Continuous scan
/// clients will get a <b>large</b> speed increase by using this instead of decode().
///
/// </summary>
/// <param name="image">The pixel data to decode
/// </param>
/// <returns> The contents of the image
/// </returns>
/// <throws> ReaderException Any errors which occurred </throws>
function DecodeWithState(image: TBinaryBitmap): TReadResult;
destructor Destroy; override;
/// <summary> This method adds state to the MultiFormatReader. By setting the hints once, subsequent calls
/// to decodeWithState(image) can reuse the same set of readers without reallocating memory. This
/// is important for performance in continuous scan clients.
///
/// </summary>
/// <param name="hints">The set of hints to use for subsequent calls to decode(image)
/// </param>
property hints: TDictionary<TDecodeHintType, TObject> read Get_Hints
write Set_Hints;
procedure Reset;
procedure FreeReaders();
end;
implementation
function TMultiFormatReader.decode(const image: TBinaryBitmap): TReadResult;
begin
hints := nil;
result := DecodeInternal(image)
end;
function TMultiFormatReader.decode(const image: TBinaryBitmap;
WithHints: Boolean): TReadResult;
begin
result := DecodeInternal(image)
end;
function TMultiFormatReader.decode(const image: TBinaryBitmap;
hints: TDictionary<TDecodeHintType, TObject>): TReadResult;
begin
FHints := hints;
result := DecodeInternal(image)
end;
function TMultiFormatReader.DecodeWithState(image: TBinaryBitmap): TReadResult;
begin
// Make sure to set up the default state so we don't crash
if readers = nil then
begin
hints := nil
end;
result := DecodeInternal(image);
end;
destructor TMultiFormatReader.Destroy;
begin
FreeReaders;
inherited;
end;
procedure TMultiFormatReader.FreeReaders;
begin
if readers <> nil then
readers.Clear();
readers.Free;
readers := nil;
end;
function TMultiFormatReader.Get_Hints: TDictionary<TDecodeHintType, TObject>;
begin
result := FHints;
end;
procedure TMultiFormatReader.Set_Hints(const Value: TDictionary<TDecodeHintType,
TObject>);
var
useCode39CheckDigit, useCode39ExtendedMode: Boolean;
formats: TList<TBarcodeFormat>;
begin
FHints := Value;
// tryHarder := (Value <> nil) and
// (Value.ContainsKey(ZXing.DecodeHintType.TRY_HARDER));
if ((Value = nil) or
(not Value.ContainsKey(ZXing.DecodeHintType.POSSIBLE_FORMATS))) then
begin
formats := nil;
end
else
begin
formats := Value[ZXing.DecodeHintType.POSSIBLE_FORMATS]
as TList<TBarcodeFormat>
end;
// add readers from the hints
readers := TList<IReader>.Create;
if formats <> nil then
begin
// 1D readers
if (formats.Contains(TBarcodeFormat.CODE_128)) then
begin
readers.Add(TCode128Reader.Create())
end;
if (formats.Contains(TBarcodeFormat.CODE_93)) then
begin
readers.Add(TCode93Reader.Create())
end;
if (formats.Contains(TBarcodeFormat.ITF)) then
begin
readers.Add(TITFReader.Create())
end;
// 2D readers
if (formats.Contains(TBarcodeFormat.QR_CODE)) then
begin
readers.Add(TQRCodeReader.Create())
end;
if formats.Contains(TBarcodeFormat.DATA_MATRIX) then
readers.Add(TDataMatrixReader.Create);
if (formats.Contains(TBarcodeFormat.EAN_13)) then
readers.Add(TEAN13Reader.Create());
if (formats.Contains(TBarcodeFormat.EAN_8)) then
readers.Add(TEAN8Reader.Create());
if (formats.Contains(TBarcodeFormat.UPC_A)) then
readers.Add(TUPCAReader.Create());
if (formats.Contains(TBarcodeFormat.UPC_E)) then
readers.Add(TUPCEReader.Create());
if (formats.Contains(TBarcodeFormat.CODE_39)) then
begin
useCode39CheckDigit := hints.ContainsKey
(TDecodeHintType.ASSUME_CODE_39_CHECK_DIGIT) and
hints.ContainsKey(TDecodeHintType.ASSUME_CODE_39_CHECK_DIGIT);
useCode39ExtendedMode := hints.ContainsKey
(TDecodeHintType.USE_CODE_39_EXTENDED_MODE) and
hints.ContainsKey(TDecodeHintType.USE_CODE_39_EXTENDED_MODE);
readers.Add(TCode39Reader.Create(useCode39CheckDigit,
useCode39ExtendedMode));
end;
end;
if (readers.Count = 0) then // must be auto, add them all
begin
// 1D readers
readers.Add(TCode128Reader.Create());
readers.Add(TUPCAReader.Create());
readers.Add(TUPCEReader.Create());
readers.Add(TEAN13Reader.Create());
readers.Add(TEAN8Reader.Create());
readers.Add(TCode93Reader.Create());
readers.Add(TITFReader.Create());
useCode39CheckDigit := hints.ContainsKey
(TDecodeHintType.ASSUME_CODE_39_CHECK_DIGIT) and hints.ContainsKey
(TDecodeHintType.ASSUME_CODE_39_CHECK_DIGIT);
useCode39ExtendedMode := hints.ContainsKey
(TDecodeHintType.USE_CODE_39_EXTENDED_MODE) and hints.ContainsKey
(TDecodeHintType.USE_CODE_39_EXTENDED_MODE);
readers.Add(TCode39Reader.Create(useCode39CheckDigit,
useCode39ExtendedMode));
// 2D readers
readers.Add(TQRCodeReader.Create());
readers.Add(TDataMatrixReader.Create)
end;
end;
procedure TMultiFormatReader.Reset;
var
Reader: IReader;
begin
if readers <> nil then
begin
for Reader in readers do
begin
Reader.Reset();
end
end
end;
function TMultiFormatReader.DecodeInternal(image: TBinaryBitmap): TReadResult;
var
rpCallBack: TResultPointCallback;
i: integer;
Reader: IReader;
begin
result := nil;
if (readers = nil) then
begin
Exit;
end;
rpCallBack := nil;
if ((FHints <> nil) and
(FHints.ContainsKey(ZXing.DecodeHintType.NEED_RESULT_POINT_CALLBACK))) then
begin
// rpCallBack := FHints[DecodeHintType.NEED_RESULT_POINT_CALLBACK]
// as TResultPointCallback(nil);
end;
for i := 0 to readers.Count - 1 do
begin
Reader := readers[i];
Reader.Reset();
result := Reader.decode(image, FHints);
if result <> nil then
begin
// found a barcode, pushing the successful reader up front
// I assume that the same type of barcode is read multiple times
// so the reordering of the readers list should speed up the next reading
// a little bit
readers.Delete(i);
readers.Insert(0, Reader);
Exit;
end;
// if rpCallBack <> nil then
// rpCallBack(nil)
end;
end;
end.
@@ -0,0 +1,344 @@
{
* Copyright 2008 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Original Author: bbrown@google.com (Brian Brown)
* Delphi Implementation by E. Spelt and K. Gossens
}
unit ZXing.ReadResult;
interface
uses
System.SysUtils,
Generics.Collections,
ZXing.ResultPoint,
ZXing.ResultMetadataType,
ZXing.BarcodeFormat,
ZXing.ByteSegments;
type
IMetaData = Interface
['{27AEB2C5-D775-44C6-9816-3E69025CA57C}']
end;
IStringMetadata = interface(IMetaData)
['{8073F897-30AD-49B7-AE0B-B187D3373163}']
function Value:String;
end;
IIntegerMetadata = interface(IMetaData)
['{CA60A23A-57ED-4C8E-9886-4F23B832A90C}']
function Value:Integer;
end;
IByteSegmentsMetadata = interface(IMetaData)
['{CA60A23A-57ED-4C8E-9886-4F23B832A90C}']
function Value:IByteSegments;
end;
/// <summary>
/// represents the metadata contained in a TReadResult and provides the
/// helping functions needed to create them
/// </summary>
TResultMetaData = class(TDictionary<TResultMetadataType, IMetaData>)
public
constructor Create;
class function CreateStringMetadata(const Value:string) :IStringMetaData;
class function CreateIntegerMetadata(const Value:integer) :IIntegerMetaData;
class function CreateByteSegmentsMetadata(const Value:IByteSegments) :IByteSegmentsMetadata;
end;
TReadResult = class
private
FText: string;
FTimeStamp: TDateTime;
FResultMetadata: TResultMetaData;
FRawBytes: TArray<Byte>;
FResultPoints: TArray<IResultPoint>;
FFormat: TBarcodeFormat;
procedure SetText(const AValue: String);
procedure SetMetaData( const Value: TResultMetadata);
public
/// <summary>
/// Initializes a new instance of the <see cref="TReadResult"/> class.
/// </summary>
/// <param name="text">The text.</param>
/// <param name="rawBytes">The raw bytes.</param>
/// <param name="resultPoints">The result points.</param>
/// <param name="format">The format.</param>
constructor Create(const text: string; const rawBytes: TArray<Byte>;
const resultPoints: TArray<IResultPoint>;
const format: TBarcodeFormat); overload;
/// <summary>
/// Initializes a new instance of the <see cref="TReadResult"/> class.
/// </summary>
/// <param name="text">The text.</param>
/// <param name="rawBytes">The raw bytes.</param>
/// <param name="resultPoints">The result points.</param>
/// <param name="format">The format.</param>
/// <param name="timestamp">The timestamp.</param>
constructor Create(const text: string; const rawBytes: TArray<Byte>;
const resultPoints: TArray<IResultPoint>; const format: TBarcodeFormat;
const timeStamp: TDateTime); overload;
destructor Destroy; override;
function ToString: String; override;
// we need a "write" procedure accessor because we need to properly deallocate
// existing instance if we overwrite it with another one
property ResultMetaData: TResultMetadata
read FResultMetadata write SetMetaData;
/// <summary>
/// Adds one metadata to the result
/// </summary>
/// <param name="type">The type.</param>
/// <param name="value">The value.</param>
procedure putMetadata(const ResultMetadataType: TResultMetadataType;
const Value: IMetaData);
/// <summary>
/// Adds a list of metadata to the result
/// </summary>
/// <param name="metadata">The metadata.</param>
procedure putAllMetaData(const metaData: TResultMetadata);
/// <summary>
/// Adds the result points.
/// </summary>
/// <param name="newPoints">The new points.</param>
procedure addResultPoints(const newPoints: TArray<IResultPoint>);
/// <returns>raw text encoded by the barcode, if applicable, otherwise <code>null</code></returns>
property text: String read FText write SetText;
/// <returns>raw bytes encoded by the barcode, if applicable, otherwise <code>null</code></returns>
property rawBytes: TArray<Byte> read FRawBytes write FRawBytes;
/// <returns>
/// points related to the barcode in the image. These are typically points
/// identifying finder patterns or the corners of the barcode. The exact meaning is
/// specific to the type of barcode that was decoded.
/// </returns>
property resultPoints: TArray<IResultPoint> read FResultPoints
write FResultPoints;
/// <returns>{@link TBarcodeFormat} representing the format of the barcode that was decoded</returns>
property BarcodeFormat: TBarcodeFormat read FFormat write FFormat;
/// <summary>
/// Gets the timestamp.
/// </summary>
property timeStamp: TDateTime read FTimeStamp;
end;
implementation
{$REGION 'IMetaData implementations'}
{ TStringMetadata }
type
TStringMetadata = class(TInterfacedObject,IMetaData,IStringMetadata)
strict private
FValue: String;
function Value: String;
private
constructor Create(const AValue: String);
end;
function TStringMetadata.Value: String;
begin
result := FValue
end;
constructor TStringMetadata.Create(const AValue: string);
begin
inherited Create;
FValue := AValue;
end;
{ TIntegerMetadata }
type
TIntegerMetadata = class(TInterfacedObject,IMetaData,IIntegerMetadata)
strict private
FValue: Integer;
function Value: Integer;
private
constructor Create(const AValue: Integer);
end;
function TIntegerMetadata.Value: Integer;
begin
result := FValue
end;
constructor TIntegerMetadata.Create(const AValue: Integer);
begin
inherited Create;
FValue := AValue;
end;
{ TByteSegmentsMetadata }
type
TByteSegmentsMetadata = class(TInterfacedObject,IMetaData,IByteSegmentsMetadata)
strict private
FValue: IByteSegments;
function Value: IByteSegments;
private
constructor Create(const AValue: IByteSegments);
end;
function TByteSegmentsMetadata.Value: IByteSegments;
begin
result := FValue
end;
constructor TByteSegmentsMetadata.Create(const AValue: IByteSegments);
begin
inherited Create;
FValue := AValue;
end;
{ TResultMetadata }
constructor TResultMetaData.Create;
begin
inherited Create;
end;
class function TResultMetadata.CreateStringMetadata(const Value:string) :IStringMetaData;
begin
result := TStringMetadata.Create(Value);
end;
class function TResultMetaData.CreateByteSegmentsMetadata(
const Value: IByteSegments): IByteSegmentsMetadata;
begin
result := TByteSegmentsMetadata.Create(value);
end;
class function TResultMetadata.CreateIntegerMetadata(const Value:integer) :IIntegerMetaData;
begin
result := TIntegerMetadata.Create(Value);
end;
{$ENDREGION 'IMetaData implementations'}
{ TReadResult }
constructor TReadResult.Create(const text: String; const rawBytes: TArray<Byte>;
const resultPoints: TArray<IResultPoint>; const format: TBarcodeFormat);
begin
Self.Create(text, rawBytes, resultPoints, format, Now);
end;
constructor TReadResult.Create(const text: String; const rawBytes: TArray<Byte>;
const resultPoints: TArray<IResultPoint>; const format: TBarcodeFormat;
const timeStamp: TDateTime);
begin
if ((text = '') and (rawBytes = nil)) then
raise EArgumentException.Create('Text and bytes are null.');
SetText(text);
FRawBytes := rawBytes;
FResultPoints := resultPoints;
FResultMetadata := nil;
FFormat := format;
FResultMetadata := nil;
FTimeStamp := timeStamp;
end;
destructor TReadResult.Destroy;
var i:Integer;
begin
for I := Low(FResultPoints) to High(FResultPoints) do
begin
FResultPoints[i] := nil;
end;
FResultPoints := nil;
FRawBytes := nil;
if FResultMetadata <> nil then
begin
FResultMetadata.Clear;
FreeAndNil(FResultMetadata);
end;
inherited;
end;
// Added (KG): UTF-8 compatiblity
procedure TReadResult.SetMetaData(const Value: TResultMetadata);
begin
if value = FResultMetadata then
exit; // no change
if FResultMetadata<>nil then
FResultMetadata.Free; // we need to free existing object instance, for old-gen compilers
FResultMetadata := Value;
end;
procedure TReadResult.SetText(const AValue: String);
begin
FText := AValue;
end;
procedure TReadResult.putMetadata(const ResultMetadataType: TResultMetadataType;
const Value: IMetaData);
begin
if (FResultMetadata = nil) then
FResultMetadata := TResultMetadata.Create();
FResultMetadata.AddOrSetValue(ResultMetadataType, Value);
end;
procedure TReadResult.putAllMetaData(const metaData: TResultMetadata);
var
key: TResultMetadataType;
begin
if (metaData <> nil) then
begin
if (FResultMetadata = nil) then
FResultMetadata := TResultMetadata.Create();
for key in metaData.Keys do
FResultMetadata.AddOrSetValue(key, metaData[key]);
end;
end;
procedure TReadResult.addResultPoints(const newPoints: TArray<IResultPoint>);
begin
FResultPoints := FResultPoints + newPoints;
end;
/// <summary>
/// Returns a <see cref="System.String"/> that represents this instance.
/// </summary>
/// <returns>
/// A <see cref="System.String"/> that represents this instance.
/// </returns>
function TReadResult.ToString(): String;
begin
if (text = '') then
Result := '[' + IntToStr(Length(rawBytes)) + ' bytes]'
else
Result := text;
end;
end.
+71
View File
@@ -0,0 +1,71 @@
{
* Copyright 2007 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Original Authors: Sean Owen and dswitkin@google.com (Daniel Switkin)
* Delphi Implementation by E. Spelt and K. Gossens
}
unit ZXing.Reader;
interface
uses
System.SysUtils,
System.Generics.Collections,
ZXing.BinaryBitmap,
ZXing.ReadResult,
ZXing.DecodeHintType;
type
/// <summary>
/// Implementations of this interface can decode an image of a barcode in some format into
/// the String it encodes. For example, <see cref="ZXing.QrCode.QRCodeReader" /> can
/// decode a QR code. The decoder may optionally receive hints from the caller which may help
/// it decode more quickly or accurately.
///
/// See <see cref="MultiFormatReader" />, which attempts to determine what barcode
/// format is present within the image as well, and then decodes it accordingly.
/// </summary>
IReader = interface
/// <summary>
/// Locates and decodes a barcode in some format within an image.
/// </summary>
/// <param name="image">image of barcode to decode</param>
/// <returns>String which the barcode encodes</returns>
function decode(const image: TBinaryBitmap): TReadResult; overload;
/// <summary> Locates and decodes a barcode in some format within an image. This method also accepts
/// hints, each possibly associated to some data, which may help the implementation decode.
/// </summary>
/// <param name="image">image of barcode to decode</param>
/// <param name="hints">passed as a <see cref="IDictionary{TKey, TValue}" /> from <see cref="DecodeHintType" />
/// to arbitrary data. The
/// meaning of the data depends upon the hint type. The implementation may or may not do
/// anything with these hints.
/// </param>
/// <returns>String which the barcode encodes</returns>
function decode(const image: TBinaryBitmap;
hints: TDictionary<TDecodeHintType, TObject>): TReadResult; overload;
/// <summary>
/// Resets any internal state the implementation has after a decode, to prepare it
/// for reuse.
/// </summary>
procedure Reset();
end;
implementation
end.
@@ -0,0 +1,108 @@
{
* Copyright 2008 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Implemented by E. Spelt for Delphi
}
unit ZXing.ResultMetadataType;
interface
type
/// <summary>
/// Represents some type of metadata about the result of the decoding that the decoder
/// wishes to communicate back to the caller.
/// </summary>
/// <author>Sean Owen</author>
TResultMetadataType = (
/// <summary>
/// Unspecified, application-specific metadata. Maps to an unspecified {@link Object}.
/// </summary>
OTHER,
/// <summary>
/// Denotes the likely approximate orientation of the barcode in the image. This value
/// is given as degrees rotated clockwise from the normal, upright orientation.
/// For example a 1D barcode which was found by reading top-to-bottom would be
/// said to have orientation "90". This key maps to an {@link Integer} whose
/// value is in the range [0,360).
/// </summary>
ORIENTATION,
/// <summary>
/// <p>2D barcode formats typically encode text, but allow for a sort of 'byte mode'
/// which is sometimes used to encode binary data. While {@link Result} makes available
/// the complete raw bytes in the barcode for these formats, it does not offer the bytes
/// from the byte segments alone.</p>
/// <p>This maps to a {@link java.util.List} of byte arrays corresponding to the
/// raw bytes in the byte segments in the barcode, in order.</p>
/// </summary>
BYTE_SEGMENTS,
/// <summary>
/// Error correction level used, if applicable. The value type depends on the
/// format, but is typically a String.
/// </summary>
ERROR_CORRECTION_LEVEL,
/// <summary>
/// For some periodicals, indicates the issue number as an {@link Integer}.
/// </summary>
ISSUE_NUMBER,
/// <summary>
/// For some products, indicates the suggested retail price in the barcode as a
/// formatted {@link String}.
/// </summary>
SUGGESTED_PRICE,
/// <summary>
/// For some products, the possible country of manufacture as a {@link String} denoting the
/// ISO country code. Some map to multiple possible countries, like "US/CA".
/// </summary>
POSSIBLE_COUNTRY,
/// <summary>
/// For some products, the extension text
/// </summary>
UPC_EAN_EXTENSION,
/// <summary>
/// If the code format supports structured append and
/// the current scanned code is part of one then the
/// sequence number is given with it.
/// </summary>
STRUCTURED_APPEND_SEQUENCE,
/// <summary>
/// If the code format supports structured append and
/// the current scanned code is part of one then the
/// parity is given with it.
/// </summary>
STRUCTURED_APPEND_PARITY,
/// <summary>
/// PDF417-specific metadata
/// </summary>
PDF417_EXTRA_METADATA,
/// <summary>
/// Aztec-specific metadata
/// </summary>
AZTEC_EXTRA_METADATA);
implementation
end.
@@ -0,0 +1,206 @@
{
* Copyright 2008 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Original Author: Sean Owen
* Delphi Implementation by E. Spelt and K. Gossens
}
unit ZXing.ResultPoint;
interface
uses
System.SysUtils,
ZXing.Common.Detector.MathUtils;
type
/// <summary>
/// To mimic "garbage collection" (or ARC) with old-gen compilers we have to use
/// interfaces. IResultPoint is the interface that maps TResultPoint which is now
/// implemented as a TInterfacedObject descendant which supports automatic deallocation
/// based on reference counting of interface variables.
/// See ZXing.ResultPointImplementation to see the actual implementation of this interface.
/// since we are using automatic reference counting, we don't need the Clone method any more.
/// </summary>
IResultPoint = interface
['{1E60EDAB-0387-440C-9D8E-4E0CC772C820}']
// property accessors, for interfaces, MUST be functions or procedures (interfaces cannot contain data)
procedure SetX(const AValue: Single);
procedure SetY(const AValue: Single);
function GetX: Single;
function GetY: Single;
function Equals(other: TObject): Boolean;
function GetHashCode(): Integer;
function ToString(): String;
property x: Single read GetX write SetX;
property y: Single read GetY write SetY;
end;
/// <summary>
/// in order to implement TResultPoint as an interface all static methods
/// have been moved in this static class.
/// this class contains also the CreateResultPoint method that must be used
/// in place of the actual class constructor
/// </summary>
TResultPointHelpers = class
protected
/// <summary>
/// Returns the z component of the cross product between vectors BC and BA.
/// </summary>
class function crossProductZ(const pointA, pointB, pointC: IResultPoint): Single; static;
public
/// <summary>
/// Initializes a new instance of <see cref="TResultPoint"/> and returns
/// its <see cref="IResultPoint"/> interface
/// </summary>
class function CreateResultPoint:IResultPoint; overload;
/// <summary>
/// Initializes a new instance of <see cref="TResultPoint"/> and returns
/// its <see cref="IResultPoint"/> interface
/// </summary>
/// <param name="x">The x.</param>
/// <param name="y">The y.</param>
class function CreateResultPoint(const pX, pY: Single):IResultPoint; overload;
/// <summary>
/// Orders an array of three ResultPoints in an order [A,B,C] such that AB is less than AC and
/// BC is less than AC and the angle between BC and BA is less than 180 degrees.
/// </summary>
/// <param name="patterns">array of three <see cref="IResultPoint" /> to order</param>
class procedure orderBestPatterns(const patterns : TArray<IResultPoint>); static;
/// <summary>
/// calculates the distance between two points
/// </summary>
/// <param name="pattern1">first pattern</param>
/// <param name="pattern2">second pattern</param>
/// <returns>
/// distance between two points
/// </returns>
class function distance(const pattern1, pattern2: IResultPoint) : Single; static;
end;
/// <summary> Callback which is invoked when a possible result point (significant
/// point in the barcode image such as a corner) is found.
///
/// </summary>
/// <seealso cref="TDecodeHintType.NEED_RESULT_POINT_CALLBACK">
/// </seealso>
TResultPointCallback = procedure(const point: IResultPoint) of object;
TResultPointEventObject = class(TObject)
private
FResultPointCallback: TResultPointCallback;
public
constructor Create(const AEvent: TResultPointCallback);
property Event: TResultPointCallback read FResultPointCallback;
end;
implementation
uses ZXing.ResultPointImplementation;
class function TResultPointHelpers.CreateResultPoint:IResultPoint;
begin
result := ZXing.ResultPointImplementation.NewResultPoint;
end;
class function TResultPointHelpers.CreateResultPoint(const pX, pY: Single):IResultPoint;
begin
result := ZXing.ResultPointImplementation.NewResultPoint(px,py);
end;
class function TResultPointHelpers.crossProductZ(const pointA, pointB,
pointC: IResultPoint): Single;
var
bX, bY: Single;
begin
bX := pointB.x;
bY := pointB.y;
Result := ((pointC.x - bX) * (pointA.y - bY)) -
((pointC.y - bY) * (pointA.x - bX));
end;
class function TResultPointHelpers.distance(const pattern1,
pattern2: IResultPoint): Single;
begin
Result := TMathUtils.distance(pattern1.x, pattern1.y, pattern2.x, pattern2.y);
end;
class procedure TResultPointHelpers.orderBestPatterns(const patterns
: TArray<IResultPoint>);
var
zeroOneDistance, oneTwoDistance, zeroTwoDistance: Single;
pointA, pointB, pointC, temp: IResultPoint;
begin
// Find distances between pattern centers
zeroOneDistance := distance(patterns[0], patterns[1]);
oneTwoDistance := distance(patterns[1], patterns[2]);
zeroTwoDistance := distance(patterns[0], patterns[2]);
// Assume one closest to other two is B; A and C will just be guesses at first
if ((oneTwoDistance >= zeroOneDistance) and
(oneTwoDistance >= zeroTwoDistance)) then
begin
pointB := patterns[0];
pointA := patterns[1];
pointC := patterns[2];
end
else if ((zeroTwoDistance >= oneTwoDistance) and
(zeroTwoDistance >= zeroOneDistance)) then
begin
pointB := patterns[1];
pointA := patterns[0];
pointC := patterns[2];
end
else
begin
pointB := patterns[2];
pointA := patterns[0];
pointC := patterns[1];
end;
// Use cross product to figure out whether A and C are correct or flipped.
// This asks whether BC x BA has a positive z component, which is the arrangement
// we want for A, B, C. If it's negative, then we've got it flipped around and
// should swap A and C.
if (crossProductZ(pointA, pointB, pointC) < 0) then
begin
temp := pointA;
pointA := pointC;
pointC := temp;
end;
patterns[0] := pointA;
patterns[1] := pointB;
patterns[2] := pointC;
end;
{ TResultPointEventObject }
constructor TResultPointEventObject.Create(const AEvent: TResultPointCallback);
begin
Self.FResultPointCallback := AEvent;
end;
end.
@@ -0,0 +1,168 @@
unit ZXing.ResultPointImplementation;
interface
uses system.SysUtils,
ZXing.ResultPoint;
type
/// <summary>
/// Encapsulates a point of interest in an image containing a barcode. Typically, this
/// would be the location of a finder pattern or the corner of the barcode, for example.
/// this class is meant to be used only indirectly, via the IResultPoint reference-counted interface
// it implements. It is exposed in the interface section just to allow the declaration of its derived classes
/// </summary>
TResultPoint = class(TInterfacedObject,IResultPoint)
private type
TSingleArray = array [0 .. Pred(SizeOf(Single))] of Byte;
var
Fx, Fy: Single;
bytesX, bytesY: TSingleArray;
FToString: String;
procedure SetX(const AValue: Single);
procedure SetY(const AValue: Single);
function GetX: Single;
function GetY: Single;
public
/// <summary>
/// Initializes a new instance of the <see cref="TResultPoint"/> class.
/// </summary>
constructor Create; overload;
/// <summary>
/// Initializes a new instance of the <see cref="TResultPoint"/> class.
/// </summary>
/// <param name="x">The x.</param>
/// <param name="y">The y.</param>
constructor Create(const pX, pY: Single); overload;
destructor Destroy; override;
/// <summary>
/// Determines whether the specified <see cref="System.TObject"/> is equal to this instance.
/// </summary>
/// <param name="other">The <see cref="System.TObject"/> to compare with this instance.</param>
/// <returns>
/// <c>true</c> if the specified <see cref="System.TObject"/> is equal to this instance; otherwise, <c>false</c>.
/// </returns>
function Equals(other: TObject): Boolean; override;
/// <summary>
/// Returns a hash code for this instance.
/// </summary>
/// <returns>
/// A hash code for this instance, suitable for use in hashing algorithms and data structures like a hash table.
/// </returns>
function GetHashCode(): Integer; override;
/// <summary>
/// Returns a <see cref="System.String"/> that represents this instance.
/// </summary>
/// <returns>
/// A <see cref="System.String"/> that represents this instance.
/// </returns>
function ToString(): String; override;
property x: Single read GetX write SetX;
property y: Single read GetY write SetY;
end;
// these are the helping functions that actually create a new instance.
// The actual constructor cannot be called outside of this unit
function NewResultPoint:IResultPoint; overload;
function NewResultPoint(const pX, pY: Single):IResultPoint; overload;
implementation
function NewResultPoint:IResultPoint;
begin
result := TResultPoint.Create;
end;
function NewResultPoint(const pX, pY: Single):IResultPoint;
begin
result := TResultPoint.Create(px,py);
end;
{ TResultPoint }
constructor TResultPoint.Create;
begin
inherited;
end;
constructor TResultPoint.Create(const pX, pY: Single);
begin
inherited Create;
Fx := pX;
Fy := pY;
bytesX := TSingleArray(pX);
bytesY := TSingleArray(pY);
end;
destructor TResultPoint.Destroy;
var
n: Single;
begin
n := 0;
bytesX := TSingleArray(n);
bytesY := TSingleArray(n);
inherited;
end;
procedure TResultPoint.SetX(const AValue: Single);
begin
if (AValue <> Fx) then
begin
Fx := AValue;
bytesX := TSingleArray(Fx);
end;
end;
procedure TResultPoint.SetY(const AValue: Single);
begin
if (AValue <> Fy) then
begin
Fy := AValue;
bytesY := TSingleArray(Fy);
end;
end;
function TResultPoint.GetX: Single;
begin
result := Fx;
end;
function TResultPoint.GetY: Single;
begin
result := Fy;
end;
function TResultPoint.Equals(other: TObject): Boolean;
var
otherPoint: TResultPoint;
begin
otherPoint := other as TResultPoint;
if (otherPoint = nil) then
Result := false
else
Result := ((otherPoint.x = Fx) and (otherPoint.y = Fy));
end;
function TResultPoint.GetHashCode: Integer;
begin
Result := 31 * ((bytesX[0] shl 24) + (bytesX[1] shl 16) + (bytesX[2] shl 8) +
bytesX[3]) + (bytesY[0] shl 24) + (bytesY[1] shl 16) + (bytesY[2] shl 8) +
bytesY[3];
end;
function TResultPoint.ToString: String;
begin
if (FToString = '') then
FToString := Format('(%g),(%g)', [Fx, Fy]);
Result := FToString;
end;
end.
@@ -0,0 +1,229 @@
unit ZXing.StringUtils;
{
* Copyright 2008 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Implemented by E. Spelt for Delphi
}
interface
uses SysUtils, Generics.Collections, ZXing.DecodeHintType;
type
TStringUtils = class abstract
const
UTF8 = 'UTF-8';
EUC_JP = 'EUC-JP';
ISO88591 = 'ISO-8859-1';
class procedure ClassInit;
class var ASSUME_SHIFT_JIS: boolean;
class var PLATFORM_DEFAULT_ENCODING: string;
public
class var GB2312: string;
class var SHIFT_JIS: string;
class function guessEncoding(bytes: TArray<Byte>;
hints: TDictionary<TDecodeHintType, TObject>): string; static;
end;
implementation
class procedure TStringUtils.ClassInit;
begin
PLATFORM_DEFAULT_ENCODING := 'ISO-8859-1'; // 'ISO 8859-15';
SHIFT_JIS := 'SJIS';
GB2312 := 'GB2312';
ASSUME_SHIFT_JIS := (string.Compare(TStringUtils.SHIFT_JIS,
TStringUtils.PLATFORM_DEFAULT_ENCODING, true) = 0) or
(string.Compare('EUC-JP', TStringUtils.PLATFORM_DEFAULT_ENCODING,
true) = 0);
end;
class function TStringUtils.guessEncoding(bytes: TArray<Byte>;
hints: TDictionary<TDecodeHintType, TObject>): string;
var
characterSet: string;
utf8BytesLeft, utf2BytesChars, utf3BytesChars, utf4BytesChars, sjisBytesLeft,
sjisKatakanaChars, sjisCurKatakanaWordLength, sjisCurDoubleBytesWordLength,
sjisMaxKatakanaWordLength, sjisMaxDoubleBytesWordLength, isoHighOther, len,
i, value: Integer;
utf8bom, canBeISO88591, canBeShiftJIS, canBeUTF8: boolean;
begin
if ((hints <> nil) and hints.ContainsKey(ZXing.DecodeHintType.CHARACTER_SET)) then
begin
characterSet := string(hints[ZXing.DecodeHintType.CHARACTER_SET]);
if (characterSet <> '') then
begin
Result := characterSet;
exit
end
end;
len := length(bytes);
canBeISO88591 := true;
canBeShiftJIS := true;
canBeUTF8 := true;
utf8BytesLeft := 0;
utf2BytesChars := 0;
utf3BytesChars := 0;
utf4BytesChars := 0;
sjisBytesLeft := 0;
sjisKatakanaChars := 0;
sjisCurKatakanaWordLength := 0;
sjisCurDoubleBytesWordLength := 0;
sjisMaxKatakanaWordLength := 0;
sjisMaxDoubleBytesWordLength := 0;
isoHighOther := 0;
utf8bom := ((((length(bytes) > 3) and (bytes[0] = $EF)) and (bytes[1] = $BB))
and (bytes[2] = $BF));
i := 0;
while (((i < len) and ((canBeISO88591 or canBeShiftJIS) or canBeUTF8))) do
begin
value := (bytes[i] and $FF);
if (canBeUTF8) then
if (utf8BytesLeft > 0) then
if ((value and $80) = 0) then
canBeUTF8 := false
else
dec(utf8BytesLeft)
else if ((value and $80) <> 0) then
if ((value and $40) = 0) then
canBeUTF8 := false
else
begin
inc(utf8BytesLeft);
if ((value and $20) = 0) then
inc(utf2BytesChars)
else
begin
inc(utf8BytesLeft);
if ((value and $10) = 0) then
inc(utf3BytesChars)
else
begin
inc(utf8BytesLeft);
if ((value and 8) = 0) then
inc(utf4BytesChars)
else
canBeUTF8 := false
end
end
end;
if (canBeISO88591) then
if ((value > $7F) and (value < 160)) then
canBeISO88591 := false
else if ((value > $9F) and (((value < $C0) or (value = $D7)) or
(value = $F7))) then
inc(isoHighOther);
if (canBeShiftJIS) then
if (sjisBytesLeft > 0) then
if (((value < $40) or (value = $7F)) or (value > $FC)) then
canBeShiftJIS := false
else
dec(sjisBytesLeft)
else if (((value = $80) or (value = 160)) or (value > $EF)) then
canBeShiftJIS := false
else if ((value > 160) and (value < $E0)) then
begin
inc(sjisKatakanaChars);
sjisCurDoubleBytesWordLength := 0;
inc(sjisCurKatakanaWordLength);
if (sjisCurKatakanaWordLength > sjisMaxKatakanaWordLength) then
sjisMaxKatakanaWordLength := sjisCurKatakanaWordLength
end
else if (value > $7F) then
begin
inc(sjisBytesLeft);
sjisCurKatakanaWordLength := 0;
inc(sjisCurDoubleBytesWordLength);
if (sjisCurDoubleBytesWordLength > sjisMaxDoubleBytesWordLength) then
sjisMaxDoubleBytesWordLength := sjisCurDoubleBytesWordLength
end
else
begin
sjisCurKatakanaWordLength := 0;
sjisCurDoubleBytesWordLength := 0
end;
inc(i)
end;
if (canBeUTF8 and (utf8BytesLeft > 0)) then
canBeUTF8 := false;
if (canBeShiftJIS and (sjisBytesLeft > 0)) then
canBeShiftJIS := false;
if (canBeUTF8 and (utf8bom or (((utf2BytesChars + utf3BytesChars) +
utf4BytesChars) > 0))) then
begin
Result := 'UTF-8';
exit
end;
if (canBeShiftJIS and ((TStringUtils.ASSUME_SHIFT_JIS or
(sjisMaxKatakanaWordLength >= 3)) or (sjisMaxDoubleBytesWordLength >= 3)))
then
begin
Result := TStringUtils.SHIFT_JIS;
exit
end;
if (canBeISO88591 and canBeShiftJIS) then
begin
if (((sjisMaxKatakanaWordLength = 2) and (sjisKatakanaChars = 2)) or
((isoHighOther * 10) >= len)) then
Result := TStringUtils.SHIFT_JIS
else
Result := 'ISO-8859-1';
exit
end;
if (canBeISO88591) then
begin
Result := 'ISO-8859-1';
exit
end;
if (canBeShiftJIS) then
begin
Result := TStringUtils.SHIFT_JIS;
exit
end;
if (canBeUTF8) then
begin
Result := 'UTF-8';
exit
end;
Result := TStringUtils.PLATFORM_DEFAULT_ENCODING;
end;
Initialization
TStringUtils.ClassInit;
end.
@@ -0,0 +1,254 @@
{
* Copyright 2007 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Original Author: dswitkin@google.com (Daniel Switkin)
* Delphi Implementation by K. Gossens
}
unit ZXing.BaseLuminanceSource;
interface
uses
System.SysUtils,
System.UITypes,
{$IFDEF FRAMEWORK_FMX}
FMX.Graphics,
{$ENDIF}
{$IFDEF FRAMEWORK_VCL}
VCL.Graphics,
{$ENDIF}
ZXing.LuminanceSource,
ZXing.InvertedLuminanceSource;
type
/// <summary>
/// The base class for luminance sources which supports
/// cropping and rotating based upon the luminance values.
/// </summary>
TBaseLuminanceSource = class abstract (TLuminanceSource)
protected
luminances: TArray<Byte>;
const
RChannelWeight : Integer = 19562;
GChannelWeight : Integer = 38550;
BChannelWeight : Integer = 7424;
ChannelWeight : Integer = 16;
function CreateLuminanceSource(const newLuminances: TArray<Byte>;
const width, height: Integer): TLuminanceSource; virtual; abstract;
public
// added the "reintroduce" keyword to shut off the "method hides another method with the same name in the base class"
constructor Create(const width, height: Integer); reintroduce; overload;
constructor Create(const luminanceArray: TArray<Byte>; const width, height: Integer); reintroduce; overload;
function getRow(const y: Integer; row: TArray<Byte>): TArray<Byte>; override;
function rotateCounterClockwise(): TLuminanceSource; override;
function rotateCounterClockwise45(): TLuminanceSource; override;
function crop(const left, top,
width, height: Integer): TLuminanceSource; override;
function Matrix: TArray<Byte>; override;
function RotateSupported: Boolean; override;
function InversionSupported: Boolean; override;
function CropSupported: Boolean; override;
function invert(): TLuminanceSource; override;
end;
implementation
{ TBaseLuminanceSource }
constructor TBaseLuminanceSource.Create(const width, height: Integer);
begin
inherited Create(width, height);
luminances := TArray<Byte>.Create();
SetLength(luminances, (width * height));
end;
/// <summary>
/// Initializes a new instance of the <see cref="BaseLuminanceSource"/> class.
/// </summary>
/// <param name="luminanceArray">The luminance array.</param>
/// <param name="width">The width.</param>
/// <param name="height">The height.</param>
constructor TBaseLuminanceSource.Create(const luminanceArray: TArray<Byte>;
const width, height: Integer);
begin
Self.Create(width, height);
Copy(luminanceArray, 0, Length(luminances));
end;
/// <summary>
/// Fetches one row of luminance data from the underlying platform's bitmap. Values range from
/// 0 (black) to 255 (white). It is preferable for implementations of this method
/// to only fetch this row rather than the whole image, since no 2D Readers may be installed and
/// getMatrix() may never be called.
/// </summary>
/// <param name="y">The row to fetch, 0 &lt;= y &lt; Height.</param>
/// <param name="row">An optional preallocated array. If null or too small, it will be ignored.
/// Always use the returned object, and ignore the .length of the array.</param>
/// <returns>
/// An array containing the luminance data.
/// </returns>
function TBaseLuminanceSource.getRow(const y: Integer;
row: TArray<Byte>): TArray<Byte>;
var
i, width: Integer;
begin
width := Self.Width;
if ((row = nil) or (Length(row) < width)) then
begin
row := nil;
row := TArray<Byte>.Create();
SetLength(row, width);
end;
for i := 0 to Pred(width) do
row[i] := luminances[y * width + i];
Result := row;
end;
function TBaseLuminanceSource.Matrix: TArray<Byte>;
begin
Result := luminances;
end;
/// <summary>
/// Returns a new object with rotated image data by 90 degrees counterclockwise.
/// Only callable if {@link #isRotateSupported()} is true.
/// </summary>
/// <returns>
/// A rotated version of this object.
/// </returns>
function TBaseLuminanceSource.rotateCounterClockwise(): TLuminanceSource;
var
rotatedLuminances : TArray<Byte>;
newWidth,
newHeight : Integer;
localLuminances : TArray<Byte>;
yold, ynew,
xold, xnew : Integer;
begin
rotatedLuminances := TArray<Byte>.Create();
SetLength(rotatedLuminances, (Width * Height));
newWidth := Height;
newHeight := Width;
localLuminances := Matrix;
for yold := 0 to Pred(Height) do
begin
for xold := 0 to Pred(Width) do
begin
ynew := newHeight - xold - 1;
xnew := yold;
rotatedLuminances[ynew * newWidth + xnew] := localLuminances[yold * Width + xold];
end;
end;
Result := CreateLuminanceSource(rotatedLuminances, newWidth, newHeight);
end;
/// <summary>
/// TODO: not implemented yet
/// </summary>
/// <returns>
/// A rotated version of this object.
/// </returns>
function TBaseLuminanceSource.rotateCounterClockwise45(): TLuminanceSource;
begin
// TODO: implement a good 45 degrees rotation without lost of information
Result := inherited rotateCounterClockwise45();
end;
/// <summary>
/// </summary>
/// <returns> Whether this subclass supports counter-clockwise rotation.</returns>
function TBaseLuminanceSource.RotateSupported: Boolean;
begin
Result := true;
end;
/// <summary>
/// Returns a new object with cropped image data. Implementations may keep a reference to the
/// original data rather than a copy. Only callable if CropSupported is true.
/// </summary>
/// <param name="left">The left coordinate, 0 &lt;= left &lt; Width.</param>
/// <param name="top">The top coordinate, 0 &lt;= top &lt;= Height.</param>
/// <param name="width">The width of the rectangle to crop.</param>
/// <param name="height">The height of the rectangle to crop.</param>
/// <returns>
/// A cropped version of this object.
/// </returns>
function TBaseLuminanceSource.Crop(const left, top,
width, height: Integer): TLuminanceSource;
var
croppedLuminances,
oldLuminances : TArray<Byte>;
oldWidth,
oldRightBound,
oldBottomBound : Integer;
yold, ynew,
xold, xnew : Integer;
begin
if ((left + width > Self.Width) or (top + height > Self.Height))
then
raise EArgumentException.Create('Crop rectangle does not fit within image data.');
croppedLuminances := TArray<Byte>.Create();
SetLength(croppedLuminances, (width * height));
oldLuminances := Self.Matrix;
oldWidth := Self.Width;
oldRightBound := left + width;
oldBottomBound := top + height;
ynew := 0;
for yold := top to Pred(oldBottomBound) do
begin
xnew := 0;
for xold := left to Pred(oldRightBound) do
croppedLuminances[ynew * width + xnew] := oldLuminances[yold * oldWidth + xold];
Inc(ynew);
end;
Result := CreateLuminanceSource(croppedLuminances, width, height);
end;
/// <summary>
/// </summary>
/// <returns> Whether this subclass supports cropping.</returns>
function TBaseLuminanceSource.CropSupported: Boolean;
begin
Result := true;
end;
/// <summary>
/// </summary>
/// <returns>Whether this subclass supports invertion.</returns>
function TBaseLuminanceSource.InversionSupported: Boolean;
begin
Result := true;
end;
/// <summary>
/// Inverts the luminance values (newValue = 255 - oldValue)
/// </summary>
function TBaseLuminanceSource.invert(): TLuminanceSource;
begin
Result := TInvertedLuminanceSource.Create(Self);
end;
end.
@@ -0,0 +1,121 @@
unit ZXing.Binarizer;
{
* Copyright 2009 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* 2015-3 Adapted for Delphi/Object Pascal FireMonkey XE7 mobile by E.Spelt
}
interface
uses
System.SysUtils,
ZXing.LuminanceSource,
ZXing.Common.BitArray,
ZXing.Common.BitMatrix;
type
/// <summary> This class hierarchy provides a set of methods to convert luminance data to 1 bit data.
/// It allows the algorithm to vary polymorphically, for example allowing a very expensive
/// thresholding technique for servers and a fast one for mobile. It also permits the implementation
/// to vary, e.g. a JNI version for Android and a Java fallback version for other platforms.
///
/// <author>dswitkin@google.com (Daniel Switkin)</author>
/// </summary>
TBinarizer = class
private
FSource: TLuminanceSource;
function GetWidth: Integer;
function GetHeight: Integer;
protected
/// <summary>
/// Initializes a new instance of the <see cref="Binarizer"/> class.
/// </summary>
/// <param name="source">The source.</param>
constructor Create(source: TLuminanceSource);
/// <summary> Converts one row of luminance data to 1 bit data. May actually do the conversion, or return
/// cached data. Callers should assume this method is expensive and call it as seldom as possible.
/// This method is intended for decoding 1D barcodes and may choose to apply sharpening.
/// For callers which only examine one row of pixels at a time, the same BitArray should be reused
/// and passed in with each call for performance. However it is legal to keep more than one row
/// at a time if needed.
/// </summary>
/// <param name="y">The row to fetch, which must be in [0, bitmap height)</param>
/// <param name="row">An optional preallocated array. If null or too small, it will be ignored.
/// If used, the Binarizer will call BitArray.clear(). Always use the returned object.
/// </param>
/// <returns> The array of bits for this row (true means black).</returns>
public
function LuminanceSource(): TLuminanceSource;
function GetBlackRow(y: Integer; row: IBitArray): IBitArray;
virtual; abstract;
function BlackMatrix: TBitMatrix; virtual; abstract;
destructor Destroy();override;
/// <summary> Creates a new object with the same type as this Binarizer implementation, but with pristine
/// state. This is needed because Binarizer implementations may be stateful, e.g. keeping a cache
/// of 1 bit data. See Effective Java for why we can't use Java's clone() method.
/// </summary>
/// <param name="source">The LuminanceSource this Binarizer will operate on.</param>
/// <returns> A new concrete Binarizer implementation object.</returns>
function createBinarizer(source: TLuminanceSource): TBinarizer;
virtual; abstract;
property Width: Integer read GetWidth;
property Height: Integer read GetHeight;
end;
implementation
{ TBinarizer }
constructor TBinarizer.Create(source: TLuminanceSource);
begin
if (source = nil) then
begin
raise EArgumentException.Create('Source must be non-null.');
end;
Self.FSource := source;
end;
destructor TBinarizer.Destroy;
begin
inherited;
end;
function TBinarizer.GetHeight: Integer;
begin
Result:= FSource.Height;
end;
function TBinarizer.GetWidth: Integer;
begin
result := FSource.Width;
end;
function TBinarizer.LuminanceSource: TLuminanceSource;
begin
result := Self.FSource;
end;
end.
@@ -0,0 +1,124 @@
{
* Copyright 2008 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Implemented by E. Spelt for Delphi
}
unit ZXing.BinaryBitmap;
interface
uses
System.SysUtils,
ZXing.Binarizer,
ZXing.LuminanceSource,
ZXing.Common.BitArray,
ZXing.Common.BitMatrix;
type
TBinaryBitmap = class
private
Binarizer: TBinarizer;
Matrix: TBitMatrix;
function GetWidth: Integer;
function GetHeight: Integer;
function GetBlackMatrix: TBitMatrix;
public
constructor Create(Binarizer: TBinarizer);
destructor Destroy(); override;
/// <summary>
/// Converts one row of luminance data to 1 bit data. May actually do the conversion, or return
/// cached data. Callers should assume this method is expensive and call it as seldom as possible.
/// This method is intended for decoding 1D barcodes and may choose to apply sharpening.
/// </summary>
/// <param name="y">The row to fetch, which must be in [0, bitmap height).</param>
/// <param name="row">An optional preallocated array. If null or too small, it will be ignored.
/// If used, the Binarizer will call BitArray.clear(). Always use the returned object.
/// </param>
/// <returns> The array of bits for this row (true means black).</returns>
function getBlackRow(y: Integer; row: IBitArray): IBitArray;
function RotateSupported: Boolean;
function rotateCounterClockwise(): TBinaryBitmap;
property Width: Integer read GetWidth;
property Height: Integer read GetHeight;
property BlackMatrix: TBitMatrix read GetBlackMatrix;
end;
implementation
{ TBinaryBitmap }
constructor TBinaryBitmap.Create(Binarizer: TBinarizer);
begin
if (Binarizer = nil) then
begin
raise EArgumentException.Create('Binarizer must be non-null.');
end;
Self.Binarizer := Binarizer;
end;
destructor TBinaryBitmap.Destroy;
begin
if Assigned(Matrix) then
FreeAndNil(Matrix);
//FreeAndNil(Binarizer);
inherited;
end;
function TBinaryBitmap.GetBlackMatrix: TBitMatrix;
begin
if (Matrix = nil) then
begin
Matrix := Binarizer.BlackMatrix();
end;
result := Matrix;
end;
function TBinaryBitmap.getBlackRow(y: Integer; row: IBitArray): IBitArray;
begin
result := Binarizer.getBlackRow(y, row);
end;
function TBinaryBitmap.GetHeight: Integer;
begin
result := Binarizer.Height;
end;
function TBinaryBitmap.GetWidth: Integer;
begin
result := Binarizer.Width;
end;
function TBinaryBitmap.rotateCounterClockwise: TBinaryBitmap;
var
newSource: TLuminanceSource;
begin
newSource := Binarizer.LuminanceSource.rotateCounterClockwise();
result := TBinaryBitmap.Create(Binarizer.createBinarizer(newSource));
end;
function TBinaryBitmap.RotateSupported: Boolean;
begin
result := Binarizer.LuminanceSource.RotateSupported();
end;
end.
@@ -0,0 +1,249 @@
unit ZXing.GlobalHistogramBinarizer;
{
* Copyright 2009 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* 2015-3 Adapted for Delphi/Object Pascal FireMonkey XE7 mobile by E.Spelt
}
interface
uses
SysUtils,
ZXing.Binarizer,
ZXing.LuminanceSource,
ZXing.Common.BitArray,
ZXing.Common.Detector.MathUtils;
type
TGlobalHistogramBinarizer = class(TBinarizer)
private
class var LUMINANCE_BITS, LUMINANCE_SHIFT, LUMINANCE_BUCKETS: Integer;
EMPTY: TArray<Byte>;
luminances: TArray<Byte>;
buckets: TArray<Integer>;
procedure InitArrays(luminanceSize: Integer);
function estimateBlackPoint(buckets: TArray<Integer>;
var blackPoint: Integer): Boolean;
class procedure ClassInit; static;
public
constructor Create(source: TLuminanceSource);
// constructor GlobalHistogramBinarizer(source: TLuminanceSource);
function GetBlackRow(y: Integer; row: IBitArray): IBitArray; override;
end;
implementation
{ TGlobalHistogramBinarizer }
class procedure TGlobalHistogramBinarizer.ClassInit();
begin
LUMINANCE_BITS := 5;
LUMINANCE_SHIFT := 8 - LUMINANCE_BITS;
LUMINANCE_BUCKETS := 1 shl LUMINANCE_BITS;
EMPTY := TArray<Byte>.Create();
SetLength(EMPTY, 0);
end;
constructor TGlobalHistogramBinarizer.Create(source: TLuminanceSource);
begin
inherited Create(source);
luminances := EMPTY;
buckets := TArray<Integer>.Create();
SetLength(self.buckets, LUMINANCE_BUCKETS);
end;
{
constructor TGlobalHistogramBinarizer.GlobalHistogramBinarizer
(source: TLuminanceSource);
begin
Inherited Create(source);
SetLength(luminances, 0);
SetLength(buckets, LUMINANCE_BUCKETS);
end;
}
function TGlobalHistogramBinarizer.GetBlackRow(y: Integer; row: IBitArray)
: IBitArray;
var
localLuminances: TArray<Byte>;
localBuckets: TArray<Integer>;
i, w, blackPoint, x, pixel, left, right, center, luminance: Integer;
begin
w := width;
if ((row = nil) or (row.Size < w)) then
begin
row := TBitArrayHelpers.CreateBitArray(w);
end
else
begin
row.Clear();
end;
InitArrays(w);
localLuminances := LuminanceSource.getRow(y, luminances);
localBuckets := buckets;
for x := 0 to w - 1 do
begin
pixel := localLuminances[x] and $FF;
i := TMathUtils.Asr(pixel, LUMINANCE_SHIFT);
localBuckets[i] := localBuckets[i] + 1;
end;
if (not estimateBlackPoint(localBuckets, blackPoint)) then
begin
result := nil;
exit;
end;
left := localLuminances[0] and $FF;
center := localLuminances[1] and $FF;
for x := 1 to w - 2 do
begin
right := localLuminances[x + 1] and $FF;
// A simple -1 4 -1 box filter with a weight of 2.
luminance := (center shl 2) - left - right;
luminance := TMathUtils.Asr(luminance, 1);
row[x] := (luminance < blackPoint);
left := center;
center := right;
end;
result := row;
end;
procedure TGlobalHistogramBinarizer.InitArrays(luminanceSize: Integer);
var
x: Integer;
begin
if (Length(luminances) < luminanceSize) then
begin
SetLength(luminances, luminanceSize);
end;
for x := 0 to LUMINANCE_BUCKETS - 1 do
begin
buckets[x] := 0;
end;
end;
function TGlobalHistogramBinarizer.estimateBlackPoint(buckets: TArray<Integer>;
var blackPoint: Integer): Boolean;
var
x, numBuckets, maxBucketCount, firstPeak, firstPeakSize, secondPeak,
secondPeakScore, distanceToBiggest, score, temp, bestValley,
bestValleyScore, fromFirst: Integer;
begin
blackPoint := 0;
// Find the tallest peak in the histogram.
numBuckets := Length(buckets);
maxBucketCount := 0;
firstPeak := 0;
firstPeakSize := 0;
for x := 0 to numBuckets - 1 do
begin
if (buckets[x] > firstPeakSize) then
begin
firstPeak := x;
firstPeakSize := buckets[x];
end;
if (buckets[x] > maxBucketCount) then
begin
maxBucketCount := buckets[x];
end;
end;
// Find the second-tallest peak which is somewhat far from the tallest peak.
secondPeak := 0;
secondPeakScore := 0;
for x := 0 to numBuckets - 1 do
begin
distanceToBiggest := x - firstPeak;
// Encourage more distant second peaks by multiplying by square of distance.
score := buckets[x] * distanceToBiggest * distanceToBiggest;
if (score > secondPeakScore) then
begin
secondPeak := x;
secondPeakScore := score;
end;
end;
// Make sure firstPeak corresponds to the black peak.
if (firstPeak > secondPeak) then
begin
temp := firstPeak;
firstPeak := secondPeak;
secondPeak := temp;
end;
// If there is too little contrast in the image to pick a meaningful black point, throw rather
// than waste time trying to decode the image, and risk false positives.
// TODO: It might be worth comparing the brightest and darkest pixels seen, rather than the
// two peaks, to determine the contrast.
if ((secondPeak - firstPeak) <= (TMathUtils.Asr(numBuckets, 4))) then
begin
result := false;
exit;
end;
// Find a valley between them that is low and closer to the white peak.
bestValley := secondPeak - 1;
bestValleyScore := -1;
x := secondPeak - 1;
while (x > firstPeak) do
begin
fromFirst := x - firstPeak;
score := fromFirst * fromFirst * (secondPeak - x) *
(maxBucketCount - buckets[x]);
if (score > bestValleyScore) then
begin
bestValley := x;
bestValleyScore := score;
end;
Dec(x);
end;
blackPoint := bestValley shl LUMINANCE_SHIFT;
result := true;
end;
Initialization
TGlobalHistogramBinarizer.ClassInit();
end.
@@ -0,0 +1,330 @@
unit ZXing.HybridBinarizer;
{
* Copyright 2009 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* 2015-3 Adapted for Delphi/Object Pascal FireMonkey XE7 mobile by E.Spelt
}
interface
uses
SysUtils,
ZXing.GlobalHistogramBinarizer,
ZXing.LuminanceSource,
ZXing.Common.BitMatrix,
ZXing.binarizer,
ZXing.Common.Detector.MathUtils;
/// <summary> This class implements a local thresholding algorithm, which while slower than the
/// GlobalHistogramBinarizer, is fairly efficient for what it does. It is designed for
/// high frequency images of barcodes with black data on white backgrounds. For this application,
/// it does a much better job than a global blackpoint with severe shadows and gradients.
/// However it tends to produce artifacts on lower frequency images and is therefore not
/// a good general purpose binarizer for uses outside ZXing.
///
/// This class extends GlobalHistogramBinarizer, using the older histogram approach for 1D readers,
/// and the newer local approach for 2D readers. 1D decoding using a per-row histogram is already
/// inherently local, and only fails for horizontal gradients. We can revisit that problem later,
/// but for now it was not a win to use local blocks for 1D.
///
/// This Binarizer is the default for the unit tests and the recommended class for library users.
///
/// </summary>
/// <author> dswitkin@google.com (Daniel Switkin)
/// </author>
/// <author>www.Redivivus.in (suraj.supekar@redivivus.in) - Ported from ZXING Java Source
/// </author>
/// <author>Adapted for Delphi/Object Pascal FireMonkey XE7 mobile by E.Spelt
/// </author>
type
TArrayIntOfInt = TArray<TArray<Integer>>;
THybridBinarizer = class(TGlobalHistogramBinarizer)
private
matrix: TBitMatrix;
procedure BinarizeEntireImage;
procedure calculateThresholdForBlock(luminances: TArray<Byte>;
subWidth: Integer; subHeight: Integer; width: Integer; height: Integer;
blackPoints: TArrayIntOfInt; matrix: TBitMatrix);
function calculateBlackPoints(luminances: TArray<Byte>; subWidth: Integer;
subHeight: Integer; width: Integer; height: Integer): TArrayIntOfInt;
procedure thresholdBlock(luminances: TArray<Byte>; xoffset: Integer;
yoffset: Integer; threshold: Integer; stride: Integer;
matrix: TBitMatrix);
function cap(value: Integer; min: Integer; max: Integer): Integer;
protected
//
public
function createBinarizer(source: TLuminanceSource): TBinarizer; override;
constructor Create(source: TLuminanceSource);
function BlackMatrix: TBitMatrix; override;
end;
implementation
{ THybridBinarizer }
function THybridBinarizer.BlackMatrix: TBitMatrix;
begin
BinarizeEntireImage();
result := matrix;
end;
function THybridBinarizer.createBinarizer(source: TLuminanceSource): TBinarizer;
begin
result := THybridBinarizer.Create(source)
end;
procedure THybridBinarizer.BinarizeEntireImage;
var
source: TLuminanceSource;
luminances: TArray<Byte>;
subWidth, subHeight, width, height: Integer;
blackPoints: TArrayIntOfInt;
newMatrix: TBitMatrix;
begin
if (self.matrix <> nil) then
begin
inherited BlackMatrix;
Exit;
end;
try
source := self.LuminanceSource;
width := source.width;
height := source.height;
if ((width >= 40) and (height >= 40)) then
begin
luminances := source.matrix;
subWidth := TMathUtils.Asr(width, 3);
if ((width and 7) <> 0) then
inc(subWidth);
subHeight := TMathUtils.Asr(height, 3);
if ((height and 7) <> 0) then
inc(subHeight);
blackPoints := calculateBlackPoints(luminances, subWidth, subHeight,
width, height);
newMatrix := TBitMatrix.Create(width, height);
calculateThresholdForBlock(luminances, subWidth, subHeight, width, height,
blackPoints, newMatrix);
self.matrix := newMatrix;
end;
finally
SetLength(blackPoints,0);
blackPoints := nil;
luminances := nil;
end;
end;
function THybridBinarizer.calculateBlackPoints(luminances: TArray<Byte>;
subWidth: Integer; subHeight: Integer; width: Integer; height: Integer)
: TArrayIntOfInt;
var
blackPoints: TArrayIntOfInt;
i, x, y, yoffset, maxYOffset, xoffset, maxXOffset, sum, min, max, yy, offset,
xx, pixel, average, averageNeighborBlackPoint: Integer;
begin
blackPoints := TArrayIntOfInt.Create();
SetLength(blackPoints, subHeight);
i := 0;
while ((i < subHeight)) do
begin
blackPoints[i] := TArray<Integer>.Create();
SetLength(blackPoints[i], subWidth);
inc(i)
end;
y := 0;
while ((y < subHeight)) do
begin
yoffset := (y shl 3);
maxYOffset := (height - 8);
if (yoffset > maxYOffset) then
yoffset := maxYOffset;
x := 0;
while ((x < subWidth)) do
begin
xoffset := (x shl 3);
maxXOffset := (width - 8);
if (xoffset > maxXOffset) then
xoffset := maxXOffset;
sum := 0;
min := $FF;
max := 0;
yy := 0;
offset := ((yoffset * width) + xoffset);
while ((yy < 8)) do
begin
xx := 0;
while ((xx < 8)) do
begin
pixel := (luminances[(offset + xx)] and $FF);
inc(sum, pixel);
if (pixel < min) then
min := pixel;
if (pixel > max) then
max := pixel;
inc(xx)
end;
if ((max - min) > $18) then
begin
inc(yy);
inc(offset, width);
while ((yy < 8)) do
begin
xx := 0;
while ((xx < 8)) do
begin
inc(sum, (luminances[(offset + xx)] and $FF));
inc(xx)
end;
inc(yy);
inc(offset, width)
end
end;
inc(yy);
inc(offset, width)
end;
average := TMathUtils.Asr(sum, 6);
if ((max - min) <= $18) then
begin
average := TMathUtils.Asr(min, 1);
if ((y > 0) and (x > 0)) then
begin
averageNeighborBlackPoint :=
TMathUtils.Asr
(((blackPoints[(y - 1)][x] + (2 * blackPoints[y][(x - 1)])) +
blackPoints[(y - 1)][(x - 1)]), 2);
if (min < averageNeighborBlackPoint) then
average := averageNeighborBlackPoint
end
end;
blackPoints[y][x] := average;
inc(x)
end;
inc(y)
end;
result := blackPoints;
end;
procedure THybridBinarizer.calculateThresholdForBlock(luminances: TArray<Byte>;
subWidth: Integer; subHeight: Integer; width: Integer; height: Integer;
blackPoints: TArrayIntOfInt; matrix: TBitMatrix);
var
y, yoffset, maxYOffset, x, xoffset, maxXOffset, left, top, sum, z,
average: Integer;
blackRow: TArray<Integer>;
begin
y := 0;
while ((y < subHeight)) do
begin
yoffset := (y shl 3);
maxYOffset := (height - 8);
if (yoffset > maxYOffset) then
yoffset := maxYOffset;
x := 0;
while ((x < subWidth)) do
begin
xoffset := (x shl 3);
maxXOffset := (width - 8);
if (xoffset > maxXOffset) then
xoffset := maxXOffset;
left := cap(x, 2, (subWidth - 3));
top := cap(y, 2, (subHeight - 3));
sum := 0;
z := -2;
while ((z <= 2)) do
begin
blackRow := blackPoints[(top + z)];
inc(sum, blackRow[(left - 2)]);
inc(sum, blackRow[(left - 1)]);
inc(sum, blackRow[left]);
inc(sum, blackRow[(left + 1)]);
inc(sum, blackRow[(left + 2)]);
inc(z)
end;
average := (sum div $19);
thresholdBlock(luminances, xoffset, yoffset, average, width, matrix);
inc(x)
end;
inc(y)
end
end;
constructor THybridBinarizer.Create(source: TLuminanceSource);
begin
inherited Create(source);
end;
procedure THybridBinarizer.thresholdBlock(luminances: TArray<Byte>;
xoffset: Integer; yoffset: Integer; threshold: Integer; stride: Integer;
matrix: TBitMatrix);
var
offset, x, y, pixel: Integer;
begin
offset := ((yoffset * stride) + xoffset);
y := 0;
while ((y < 8)) do
begin
x := 0;
while ((x < 8)) do
begin
pixel := (luminances[(offset + x)] and $FF);
matrix[(xoffset + x), (yoffset + y)] := (pixel <= threshold);
inc(x)
end;
inc(y);
inc(offset, stride)
end
end;
function THybridBinarizer.cap(value: Integer; min: Integer;
max: Integer): Integer;
begin
if (value < min) then
begin
result := min
end
else if (value > max) then
begin
result := max
end
else
result := value
end;
end.
@@ -0,0 +1,159 @@
{
* Copyright 2013 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Original Author: dswitkin@google.com (Daniel Switkin)
* Delphi Implementation by K. Gossens
}
unit ZXing.InvertedLuminanceSource;
interface
uses
System.SysUtils,
ZXing.LuminanceSource;
type
TInvertedLuminanceSource = class sealed(TLuminanceSource)
private
delegate: TLuminanceSource;
invertedMatrix: TArray<Byte>;
public
constructor Create(delegate: TLuminanceSource); reintroduce;
function crop(const left, top, width, height: Integer): TLuminanceSource; override;
function getRow(const y: Integer; row: TArray<Byte>): TArray<Byte>; override;
function rotateCounterClockwise(): TLuminanceSource; override;
function rotateCounterClockwise45(): TLuminanceSource; override;
function invert: TLuminanceSource; override;
function Matrix: TArray<Byte>; override;
function CropSupported: Boolean; override;
function RotateSupported: Boolean; override;
end;
implementation
{ TInvertedLuminanceSource }
/// <summary>
/// Initializes a new instance of the <see cref="InvertedLuminanceSource"/> class.
/// </summary>
/// <param name="delegate">The @delegate.</param>
constructor TInvertedLuminanceSource.Create(delegate: TLuminanceSource);
begin
inherited Create(delegate.Width, delegate.Height);
Self.delegate := delegate;
end;
/// <summary>
/// Fetches one row of luminance data from the underlying platform's bitmap. Values range from
/// 0 (black) to 255 (white). Because Java does not have an unsigned byte type, callers will have
/// to bitwise and with 0xff for each value. It is preferable for implementations of this method
/// to only fetch this row rather than the whole image, since no 2D Readers may be installed and
/// getMatrix() may never be called.
/// </summary>
/// <param name="y">The row to fetch, 0 &lt;= y &lt; Height.</param>
/// <param name="row">An optional preallocated array. If null or too small, it will be ignored.
/// Always use the returned object, and ignore the .length of the array.</param>
/// <returns>
/// An array containing the luminance data.
/// </returns>
function TInvertedLuminanceSource.getRow(const y: Integer; row: TArray<Byte>): TArray<Byte>;
var
rowArray : TArray<Byte>;
i, width : Integer;
begin
rowArray := delegate.getRow(y, row);
width := Self.Width;
for i := 0 to Pred(width) do
rowArray[i] := (255 - (row[i] and $FF));
Result := rowArray;
end;
/// <summary>
/// Fetches luminance data for the underlying bitmap. Values should be fetched using:
/// int luminance = array[y * width + x] &amp; 0xff;
/// </summary>
/// <returns> A row-major 2D array of luminance values. Do not use result.length as it may be
/// larger than width * height bytes on some platforms. Do not modify the contents
/// of the result.
/// </returns>
function TInvertedLuminanceSource.Matrix: TArray<Byte>;
var
matrixArray: TArray<Byte>;
i, len: Integer;
begin
if (invertedMatrix = nil) then
begin
matrixArray := delegate.Matrix;
len := Self.Width * Self.Height;
invertedMatrix := TArray<Byte>.Create();
SetLength(invertedMatrix, len);
for i := 0 to Pred(len) do
invertedMatrix[i] := (255 - (matrixArray[i] and $FF));
Result := invertedMatrix;
end;
end;
/// <summary>
/// </summary>
/// <returns> Whether this subclass supports cropping.</returns>
function TInvertedLuminanceSource.CropSupported: Boolean;
begin
Result := delegate.CropSupported;
end;
/// <summary>
/// Returns a new object with cropped image data. Implementations may keep a reference to the
/// original data rather than a copy. Only callable if CropSupported is true.
/// </summary>
/// <param name="left">The left coordinate, 0 &lt;= left &lt; Width.</param>
/// <param name="top">The top coordinate, 0 &lt;= top &lt;= Height.</param>
/// <param name="width">The width of the rectangle to crop.</param>
/// <param name="height">The height of the rectangle to crop.</param>
/// <returns>
/// A cropped version of this object.
/// </returns>
function TInvertedLuminanceSource.crop(const left, top,
width, height: Integer): TLuminanceSource;
begin
Result := TInvertedLuminanceSource.Create(Self.delegate.crop(left, top,
width, height));
end;
function TInvertedLuminanceSource.invert: TLuminanceSource;
begin
Result := self.delegate;
end;
function TInvertedLuminanceSource.rotateCounterClockwise(): TLuminanceSource;
begin
Result := TInvertedLuminanceSource.Create(Self.delegate.rotateCounterClockwise);
end;
function TInvertedLuminanceSource.rotateCounterClockwise45(): TLuminanceSource;
begin
Result := TInvertedLuminanceSource.Create(Self.delegate.rotateCounterClockwise45);
end;
function TInvertedLuminanceSource.RotateSupported: Boolean;
begin
Result := delegate.RotateSupported;;
end;
end.
@@ -0,0 +1,221 @@
{
* Copyright 2009 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Original Author: dswitkin@google.com (Daniel Switkin)
* Delphi Implementation by E.Spelt and K. Gossens
}
unit ZXing.LuminanceSource;
interface
uses
System.SysUtils;
type
/// <summary>
/// The purpose of this class hierarchy is to abstract different bitmap implementations across
/// platforms into a standard interface for requesting greyscale luminance values. The interface
/// only provides immutable methods; therefore crop and rotation create copies. This is to ensure
/// that one Reader does not modify the original luminance source and leave it in an unknown state
/// for other Readers in the chain.
/// </summary>
TLuminanceSource = class
protected
FWidth: Integer;
FHeight: Integer;
public
constructor Create(const width, height: Integer); virtual;
/// <summary>
/// Fetches luminance data for the underlying bitmap. Values should be fetched using:
/// <code>int luminance = array[y * width + x] and 0xff</code>
/// </summary>
/// <returns>
/// A row-major 2D array of luminance values. Do not use result.length as it may be
/// larger than width * height bytes on some platforms. Do not modify the contents
/// of the result.
/// </returns>
function Matrix: TArray<byte>; virtual; abstract;
/// <summary>
/// Fetches one row of luminance data from the underlying platform's bitmap. Values range from
/// 0 (black) to 255 (white). Because Java does not have an unsigned byte type, callers will have
/// to bitwise and with 0xff for each value. It is preferable for implementations of this method
/// to only fetch this row rather than the whole image, since no 2D Readers may be installed and
/// getMatrix() may never be called.
/// </summary>
/// <param name="y">The row to fetch, which must be in [0, bitmap height)</param>
/// <param name="row">An optional preallocated array. If null or too small, it will be ignored.
/// Always use the returned object, and ignore the .length of the array.
/// </param>
/// <returns> An array containing the luminance data.</returns>
function getRow(const y: Integer; row: TArray<byte>): TArray<byte>;
virtual; abstract;
/// <summary>
/// Returns a new object with cropped image data. Implementations may keep a reference to the
/// original data rather than a copy. Only callable if CropSupported is true.
/// </summary>
/// <param name="left">The left coordinate, which must be in [0, Width)</param>
/// <param name="top">The top coordinate, which must be in [0, Height)</param>
/// <param name="width">The width of the rectangle to crop.</param>
/// <param name="height">The height of the rectangle to crop.</param>
/// <returns> A cropped version of this object.</returns>
function crop(const left, top, width,
height: Integer): TLuminanceSource; virtual;
function invert(): TLuminanceSource; virtual;
function ToString(): String; override;
/// <returns> Whether this subclass supports counter-clockwise rotation.</returns>
function RotateSupported: Boolean; virtual;
/// <returns> Whether this subclass supports cropping.</returns>
function CropSupported(): Boolean; virtual;
/// <returns>Whether this subclass supports invertion.</returns>
function InversionSupported: Boolean; virtual;
/// <summary>
/// Returns a new object with rotated image data by 90 degrees counterclockwise.
/// Only callable if <see cref="RotateSupported"/> is true.
/// </summary>
/// <returns>A rotated version of this object.</returns>
function rotateCounterClockwise(): TLuminanceSource; virtual;
/// <summary>
/// Returns a new object with rotated image data by 45 degrees counterclockwise.
/// Only callable if <see cref="RotateSupported"/> is true.
/// </summary>
/// <returns>A rotated version of this object.</returns>
function rotateCounterClockwise45(): TLuminanceSource; virtual;
/// <returns> The height of the bitmap.</returns>
property Height: Integer read FHeight;
/// <returns> The width of the bitmap.</returns>
property Width: Integer read FWidth;
end;
implementation
constructor TLuminanceSource.Create(const width, height: Integer);
begin
FWidth := width;
FHeight := height;
end;
function TLuminanceSource.CropSupported: Boolean;
begin
Result := False;
end;
// <returns> Whether this subclass supports counter-clockwise rotation.</returns>
function TLuminanceSource.RotateSupported: Boolean;
begin
Result := False;
end;
/// <returns>Whether this subclass supports invertion.</returns>
function TLuminanceSource.InversionSupported: Boolean;
begin
Result := False;
end;
/// <summary>
/// Returns a new object with cropped image data. Implementations may keep a reference to the
/// original data rather than a copy. Only callable if CropSupported is true.
/// </summary>
/// <param name="left">The left coordinate, which must be in [0, Width)</param>
/// <param name="top">The top coordinate, which must be in [0, Height)</param>
/// <param name="width">The width of the rectangle to crop.</param>
/// <param name="height">The height of the rectangle to crop.</param>
/// <returns> A cropped version of this object.</returns>
function TLuminanceSource.Crop(const left, top,
width, height: Integer): TLuminanceSource;
begin
raise ENotImplemented.Create
('This luminance source does not support cropping.');
end;
/// <summary>
/// Returns a new object with rotated image data by 90 degrees counterclockwise.
/// Only callable if <see cref="RotateSupported"/> is true.
/// </summary>
/// <returns>A rotated version of this object.</returns>
function TLuminanceSource.rotateCounterClockwise(): TLuminanceSource;
begin
raise ENotImplemented.Create
('This luminance source does not support rotation.');
end;
/// <summary>
/// Returns a new object with rotated image data by 45 degrees counterclockwise.
/// Only callable if <see cref="RotateSupported"/> is true.
/// </summary>
/// <returns>A rotated version of this object.</returns>
function TLuminanceSource.rotateCounterClockwise45(): TLuminanceSource;
begin
raise ENotImplemented.Create
('This luminance source does not support rotation by 45 degrees.');
end;
function TLuminanceSource.invert(): TLuminanceSource;
begin
raise ENotImplemented.Create
('This luminance source does not support inversion.');
end;
function TLuminanceSource.ToString(): String;
var
row: TArray<byte>;
res: TStringBuilder;
x, y,
luminance: Integer;
c: char;
begin
row := TArray<Byte>.Create();
SetLength(row, FWidth);
res := TStringBuilder.Create(height * (width + 1));
try
for y := 0 to FHeight - 1 do
begin
row := GetRow(y, row);
for x := 0 to Pred(FWidth) do
begin
luminance := row[x] and $FF;
if (luminance < $40)
then
c := '#'
else
if (luminance < $80)
then
c := '+'
else
if (luminance < $C0)
then
c := '.'
else
c := ' ';
res.Append(c);
end;
res.Append(#10);
end;
finally
row := nil; // ES: can become a be a big memory hog, so release it as quickly as possible.
Result := res.ToString;
res.Free;
end;
end;
end.
@@ -0,0 +1,327 @@
{
* Copyright 2009 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Original Author: dswitkin@google.com (Daniel Switkin)
* Delphi Implementation K. Gossens
}
unit ZXing.PlanarYUVLuminanceSource;
interface
uses
System.SysUtils,
System.UITypes,
System.TypInfo,
ZXing.LuminanceSource,
ZXing.BaseLuminanceSource;
type
/// <summary>
/// Luminance source class which support different formats of images.
/// </summary>
TPlanarYUVLuminanceSource = class(TBaseLuminanceSource)
private
yuvData : TArray<Byte>;
dataWidth,
dataHeight,
left, top : Integer;
const
THUMBNAIL_SCALE_FACTOR : Integer = 2;
procedure reverseHorizontal(const width, height: Integer);
protected
function CreateLuminanceSource(const newLuminances: TArray<Byte>;
const width, height: Integer): TLuminanceSource; override;
public
constructor Create(const yuvData: TArray<Byte>;
const dataWidth, dataHeight, left, top, width, height: Integer;
const reverseHoriz: Boolean); overload;
constructor Create(const luminances: TArray<Byte>;
const width, height: Integer); overload;
function getRow(const y: Integer; row: TArray<Byte>): TArray<Byte>; override;
function crop(const left, top,
width, height: Integer): TLuminanceSource; override;
function Matrix: TArray<Byte>; override;
function CropSupported: Boolean; override;
function renderThumbnail(): TArray<Integer>;
function ThumbnailWidth(): Integer;
function ThumbnailHeight(): Integer;
end;
implementation
/// <summary>
/// Initializes a new instance of the <see cref="PlanarYUVLuminanceSource"/> class.
/// </summary>
/// <param name="yuvData">The yuv data.</param>
/// <param name="dataWidth">Width of the data.</param>
/// <param name="dataHeight">Height of the data.</param>
/// <param name="left">The left.</param>
/// <param name="top">The top.</param>
/// <param name="width">The width.</param>
/// <param name="height">The height.</param>
/// <param name="reverseHoriz">if set to <c>true</c> [reverse horiz].</param>
constructor TPlanarYUVLuminanceSource.Create(const yuvData: TArray<Byte>;
const dataWidth, dataHeight, left, top, width, height: Integer;
const reverseHoriz: Boolean);
begin
inherited Create(width, height);
if ((left + width > dataWidth) or (top + height > dataHeight))
then
raise EArgumentException.Create('Crop rectangle does not fit within image data.');
Self.yuvData := yuvData;
Self.dataWidth := dataWidth;
Self.dataHeight := dataHeight;
Self.left := left;
Self.top := top;
if (reverseHoriz)
then
reverseHorizontal(width, height);
end;
/// <summary>
/// Initializes a new instance of the <see cref="PlanarYUVLuminanceSource"/> class.
/// </summary>
/// <param name="luminances">The luminances.</param>
/// <param name="width">The width.</param>
/// <param name="height">The height.</param>
constructor TPlanarYUVLuminanceSource.Create(const luminances: TArray<Byte>;
const width, height: Integer);
begin
inherited Create(width, height);
Self.yuvData := luminances;
Self.luminances := luminances;
Self.dataWidth := width;
Self.dataHeight := height;
Self.left := 0;
Self.top := 0;
end;
/// <summary>
/// Fetches one row of luminance data from the underlying platform's bitmap. Values range from
/// 0 (black) to 255 (white). Because Java does not have an unsigned byte type, callers will have
/// to bitwise and with 0xff for each value. It is preferable for implementations of this method
/// to only fetch this row rather than the whole image, since no 2D Readers may be installed and
/// getMatrix() may never be called.
/// </summary>
/// <param name="y">The row to fetch, 0 &lt;= y &lt; Height.</param>
/// <param name="row">An optional preallocated array. If null or too small, it will be ignored.
/// Always use the returned object, and ignore the .length of the array.</param>
/// <returns>
/// An array containing the luminance data.
/// </returns>
function TPlanarYUVLuminanceSource.getRow(const y: Integer;
row: TArray<Byte>): TArray<Byte>;
var
width,
offset: Integer;
begin
if ((y < 0) or (y >= Height))
then
raise EArgumentException.Create('Requested row is outside the image: ' + IntToStr(y));
width := Self.Width;
if ((row = nil) or (Length(row) < width)) then
begin
row := nil;
row := TArray<Byte>.Create();
SetLength(row, width);
end;
offset := (y + top) * dataWidth + left;
row := Copy(yuvData, offset, width);
Result := row;
end;
/// <summary>
///
/// </summary>
function TPlanarYUVLuminanceSource.Matrix: TArray<Byte>;
var
width,
height,
area, y : Integer;
inputOffset,
outputOffset : Integer;
matrix,
yuv: TArray<Byte>;
begin
width := Self.Width;
height := Self.Height;
// If the caller asks for the entire underlying image, save the copy and give them the
// original data. The docs specifically warn that result.length must be ignored.
if ((width = dataWidth) and (height = dataHeight)) then
begin
Result := Self.yuvData;
exit;
end;
area := width * height;
matrix := TArray<Byte>.Create();
SetLength(matrix, area);
inputOffset := (top * dataWidth) + left;
// If the width matches the full width of the underlying data, perform a single copy.
if (width = dataWidth) then
begin
matrix := Copy(yuvData, inputOffset, area);
Result := matrix;
exit;
end;
// Otherwise copy one cropped row at a time.
yuv := yuvData;
for y := 0 to Pred(height) do
begin
outputOffset := y * width;
Move(yuv[inputOffSet], matrix[outputOffset], width);
Inc(inputOffset, dataWidth);
end;
Result := matrix;
end;
/// <summary>
/// </summary>
/// <returns> Whether this subclass supports cropping.</returns>
function TPlanarYUVLuminanceSource.CropSupported: Boolean;
begin
Result := true;
end;
/// <summary>
/// Returns a new object with cropped image data. Implementations may keep a reference to the
/// original data rather than a copy. Only callable if CropSupported is true.
/// </summary>
/// <param name="left">The left coordinate, 0 &lt;= left &lt; Width.</param>
/// <param name="top">The top coordinate, 0 &lt;= top &lt;= Height.</param>
/// <param name="width">The width of the rectangle to crop.</param>
/// <param name="height">The height of the rectangle to crop.</param>
/// <returns>
/// A cropped version of this object.
/// </returns>
function TPlanarYUVLuminanceSource.crop(const left, top,
width, height: Integer): TLuminanceSource;
begin
Result := TPlanarYUVLuminanceSource.Create(yuvData,
dataWidth,
dataHeight,
Self.left + left,
Self.top + top,
width,
height,
false);
end;
/// <summary>
/// Renders the cropped greyscale bitmap.
/// </summary>
/// <returns></returns>
function TPlanarYUVLuminanceSource.renderThumbnail(): TArray<Integer>;
var
width,
height : Integer;
pixels : TArray<Integer>;
yuv : TArray<Byte>;
x, y,
inputOffset,
outputOffset : Integer;
grey : Byte;
begin
width := Self.Width div THUMBNAIL_SCALE_FACTOR;
height := Self.Height div THUMBNAIL_SCALE_FACTOR;
pixels := TArray<Integer>.Create();
SetLength(pixels, (width * height));
yuv := yuvData;
inputOffset := (top * dataWidth) + left;
for y := 0 to Pred(height) do
begin
outputOffset := y * width;
for x := 0 to Pred(width) do
begin
grey := yuv[inputOffset + x * THUMBNAIL_SCALE_FACTOR] and $ff;
pixels[outputOffset + x] := (($00FF0000 shl 8) or (grey * $00010101));
end;
Inc(inputOffset, (dataWidth * THUMBNAIL_SCALE_FACTOR));
end;
Result := pixels;
end;
/// <summary>
/// width of image from {@link #renderThumbnail()}
/// </summary>
function TPlanarYUVLuminanceSource.ThumbnailWidth(): Integer;
begin
Result := (Self.Width div THUMBNAIL_SCALE_FACTOR);
end;
/// <summary>
/// height of image from {@link #renderThumbnail()}
/// </summary>
function TPlanarYUVLuminanceSource.ThumbnailHeight(): Integer;
begin
Result := (Self.Height div THUMBNAIL_SCALE_FACTOR);
end;
procedure TPlanarYUVLuminanceSource.reverseHorizontal(const width, height: Integer);
var
yuvData : TArray<Byte>;
y,
x1, x2,
middle,
rowStart : Integer;
temp : Byte;
begin
yuvData := Self.yuvData;
y := 0;
rowStart := ((self.top * self.dataWidth) + self.left);
while ((y < height)) do
begin
middle := (rowStart + (width div 2));
x1 := rowStart;
x2 := ((rowStart + width) - 1);
while ((x1 < middle)) do
begin
temp := yuvData[x1];
yuvData[x1] := yuvData[x2];
yuvData[x2] := temp;
Inc(x1);
Dec(x2)
end;
Inc(y);
Inc(rowStart, self.dataWidth)
end;
end;
function TPlanarYUVLuminanceSource.CreateLuminanceSource(
const newLuminances: TArray<Byte>;
const width, height: Integer): TLuminanceSource;
begin
Result := TPlanarYUVLuminanceSource.Create(newLuminances, width, height);
end;
end.
@@ -0,0 +1,565 @@
{
* Copyright 2012 ZXing authors
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
* Original Author: dswitkin@google.com (Daniel Switkin)
* Delphi Implementation by E.Spelt and K. Gossens
}
unit ZXing.RGBLuminanceSource;
interface
uses
System.SysUtils,
System.UITypes,
System.TypInfo,
{$IFDEF FRAMEWORK_FMX}
FMX.Graphics,
{$ENDIF}
{$IFDEF FRAMEWORK_VCL}
Winapi.Windows,
VCL.Graphics,
{$ENDIF}
ZXing.LuminanceSource,
ZXing.BaseLuminanceSource,
ZXing.Common.Detector.MathUtils;
type
/// <summary>
/// enumeration of supported bitmap format which the RGBLuminanceSource can process
/// </summary>
TBitmapFormat = (
/// <summary>
/// format of the byte[] isn't known. RGBLuminanceSource tries to determine the best possible value
/// </summary>
Unknown,
/// <summary>
/// grayscale array, the byte array is a luminance array with 1 byte per pixel
/// </summary>
Gray8,
/// <summary>
/// 3 bytes per pixel with the channels red, green and blue
/// </summary>
RGB24,
/// <summary>
/// 4 bytes per pixel with the channels red, green and blue
/// </summary>
RGB32,
/// <summary>
/// 4 bytes per pixel with the channels alpha, red, green and blue
/// </summary>
ARGB32,
/// <summary>
/// 3 bytes per pixel with the channels blue, green and red
/// </summary>
BGR24,
/// <summary>
/// 4 bytes per pixel with the channels blue, green and red
/// </summary>
BGR32,
/// <summary>
/// 4 bytes per pixel with the channels blue, green, red and alpha
/// </summary>
BGRA32,
/// <summary>
/// 2 bytes per pixel, 5 bit red, 6 bits green and 5 bits blue
/// </summary>
RGB565,
/// <summary>
/// 4 bytes per pixel with the channels red, green, blue and alpha
/// </summary>
RGBA32);
/// <summary>
/// Luminance source class which support different formats of images.
/// </summary>
TRGBLuminanceSource = class(TBaseLuminanceSource)
private
function DetermineBitmapFormat(const rgbRawBytes: TArray<Byte>;
const width, height: Integer): TBitmapFormat;
procedure CalculateLuminanceRGB24(const rgbRawBytes: TArray<Byte>);
procedure CalculateLuminanceRGB32(const rgbRawBytes: TArray<Byte>);
procedure CalculateLuminanceRGBA32(const rgbRawBytes: TArray<Byte>);
procedure CalculateLuminanceRGB565(const rgb565RawData: TArray<Byte>);
procedure CalculateLuminanceBGR24(const rgbRawBytes: TArray<Byte>);
procedure CalculateLuminanceBGR32(const rgbRawBytes: TArray<Byte>);
procedure CalculateLuminanceBGRA32(const rgbRawBytes: TArray<Byte>);
procedure CalculateLuminanceARGB32(const rgbRawBytes: TArray<Byte>);
function GetBitmapFormat: TBitmapFormat;
protected
function CreateLuminanceSource(const newLuminances: TArray<Byte>;
const width, height: Integer): TLuminanceSource; override;
procedure CalculateLuminance(const rgbRawBytes: TArray<Byte>;
bitmapFormat: TBitmapFormat);
public
constructor Create(const width, height: Integer); overload;
constructor Create(const rgbRawBytes: TArray<Byte>;
const width, height: Integer); overload;
constructor Create(const rgbRawBytes: TArray<Byte>;
const width, height: Integer; const bitmapFormat: TBitmapFormat); overload;
constructor CreateFromBitmap(const sourceBitmap: TBitmap;
const width, height: Integer);
property BitmapFormat : TBitmapFormat read GetBitmapFormat;
end;
implementation
uses ZXing.Helpers;
/// <summary>
/// Initializes a new instance of the <see cref="RGBLuminanceSource"/> class.
/// </summary>
/// <param name="width">The width.</param>
/// <param name="height">The height.</param>
constructor TRGBLuminanceSource.Create(const width, height: Integer);
begin
inherited Create(width, height);
end;
/// <summary>
/// Initializes a new instance of the <see cref="RGBLuminanceSource"/> class.
/// It supports a byte array with 3 bytes per pixel (RGB24).
/// </summary>
/// <param name="rgbRawBytes">The RGB raw bytes.</param>
/// <param name="width">The width.</param>
/// <param name="height">The height.</param>
constructor TRGBLuminanceSource.Create(const rgbRawBytes: TArray<Byte>;
const width, height: Integer);
begin
Create(rgbRawBytes, width, height, TBitmapFormat.RGB24);
end;
/// <summary>
/// Initializes a new instance of the <see cref="RGBLuminanceSource"/> class.
/// It supports a byte array with 3 bytes per pixel (RGB24).
/// </summary>
/// <param name="rgbRawBytes">The RGB raw bytes.</param>
/// <param name="width">The width.</param>
/// <param name="height">The height.</param>
/// <param name="bitmapFormat">The bitmap format.</param>
constructor TRGBLuminanceSource.Create(const rgbRawBytes: TArray<Byte>;
const width, height: Integer; const bitmapFormat: TBitmapFormat);
begin
inherited Create(width, height);
CalculateLuminance(rgbRawBytes, bitmapFormat);
end;
{$IFDEF FRAMEWORK_FMX}
// FMX TBitmap implementation
constructor TRGBLuminanceSource.CreateFromBitmap(const sourceBitmap: TBitmap;
const width, height: Integer);
var
x, y,
offset : Integer;
color : TAlphaColor;
r, g, b : Byte;
currentData: TBitmapData;
begin
Self.Create(width, height);
// In order to measure pure decoding speed, we convert the entire image to a greyscale array
// up front, which is the same as the Y channel of the YUVLuminanceSource in the real app.
if (sourceBitmap.Map(TMapAccess.Read, currentData)) then
begin
try
for y := 0 to FHeight - 1 do
begin
offset := y * FWidth;
for x := 0 to FWidth - 1 do
begin
color := currentData.GetPixel(x, y);
r := TAlphaColorRec(color).R;
g := TAlphaColorRec(color).G;
b := TAlphaColorRec(color).B;
luminances[offset + x] := TMathUtils.Asr(3482*r + 11721*g + 1181*b, 14);
end;
end;
finally
sourceBitmap.Unmap(currentData);
//sourceBitmap.DisposeOf();
end;
end;
end;
{$ENDIF}
{$IFDEF FRAMEWORK_VCL}
// VCL TBitmap implementation
constructor TRGBLuminanceSource.CreateFromBitmap(const sourceBitmap: TBitmap; const width, height: Integer);
type
TRGBTripleArray = ARRAY[Word] of TRGBTriple;
pRGBTripleArray = ^TRGBTripleArray; // Use a PByteArray for pf8bit color.
var
x, y,
offset : Integer;
r, g, b : Byte;
P: pRGBTripleArray;
begin
Self.Create(width, height);
sourceBitmap.PixelFormat := pf24bit;
for y := 0 to sourceBitmap.Height - 1 do
begin
offset := y * FWidth;
P := sourceBitmap.ScanLine[y];
for x := 0 to sourceBitmap.Width - 1 do
begin
r := P[x].rgbtRed;
g := P[x].rgbtGreen;
b := P[x].rgbtBlue;
luminances[offset + x] := TMathUtils.Asr(3482*r + 11721*g + 1181*b, 14);
end;
end;
end;
{$ENDIF}
/// <summary>
/// Should create a new luminance source with the right class type.
/// The method is used in methods crop and rotate.
/// </summary>
/// <param name="newLuminances">The new luminances.</param>
/// <param name="width">The width.</param>
/// <param name="height">The height.</param>
/// <returns></returns>
function TRGBLuminanceSource.CreateLuminanceSource(
const newLuminances: TArray<Byte>;
const width, height: Integer): TLuminanceSource;
begin
Result := TRGBLuminanceSource.Create(width, height);
luminances := newLuminances;
end;
function TRGBLuminanceSource.DetermineBitmapFormat(
const rgbRawBytes: TArray<Byte>;
const width, height: Integer): TBitmapFormat;
var
square,
byteperpixel : Integer;
begin
square := (width * height);
byteperpixel := (Length(rgbRawBytes) div square);
case byteperpixel of
1: Result := TBitmapFormat.Gray8;
2: Result := TBitmapFormat.RGB565;
3: Result := TBitmapFormat.RGB24;
4: Result := TBitmapFormat.RGB32;
else
raise EArgumentException.Create('The bitmap format could not be determined. Please specify the correct value.');
end;
end;
procedure TRGBLuminanceSource.CalculateLuminance(const rgbRawBytes: TArray<Byte>;
bitmapFormat: TBitmapFormat);
var
len: Integer;
begin
if (bitmapFormat = TBitmapFormat.Unknown)
then
bitmapFormat := DetermineBitmapFormat(rgbRawBytes, self.Width, self.Height);
case bitmapFormat of
TBitmapFormat.Gray8 :
begin
if (Length(rgbRawBytes) < Length(luminances))
then
len := Length(rgbRawBytes)
else
len := Length(luminances);
Copy(rgbRawBytes, 0, len);
end;
TBitmapFormat.RGB24 :
begin
CalculateLuminanceRGB24(rgbRawBytes);
end;
TBitmapFormat.RGB32 :
begin
CalculateLuminanceRGB32(rgbRawBytes);
end;
TBitmapFormat.ARGB32 :
begin
CalculateLuminanceARGB32(rgbRawBytes);
end;
TBitmapFormat.BGR24 :
begin
CalculateLuminanceBGR24(rgbRawBytes);
end;
TBitmapFormat.BGR32 :
begin
CalculateLuminanceBGR32(rgbRawBytes);
end;
TBitmapFormat.BGRA32 :
begin
CalculateLuminanceBGRA32(rgbRawBytes);
end;
TBitmapFormat.RGB565 :
begin
CalculateLuminanceRGB565(rgbRawBytes);
end;
TBitmapFormat.RGBA32 :
begin
CalculateLuminanceRGBA32(rgbRawBytes);
end;
else
raise EArgumentException.Create('The bitmap format isn''t supported.' +
GetEnumName(TypeInfo(TBitmapFormat), Ord(bitmapFormat)))
end;
end;
procedure TRGBLuminanceSource.CalculateLuminanceRGB565(
const rgb565RawData: TArray<Byte>);
var
luminanceIndex,
index : Integer;
byte1,
byte2,
b5, g5, r5,
r8, g8, b8 : Byte;
begin
luminanceIndex := 0;
index := 0;
while (((index < Length(rgb565RawData)) and
(luminanceIndex < Length(luminances)))) do
begin
byte1 := rgb565RawData[index];
byte2 := rgb565RawData[index + 1];
b5 := (byte1 and $1F);
g5 := (TMathUtils.Asr(byte1 and $E0 , 5) or ((byte2 and $03) shl 3)) and $1F;
r5 := TMathUtils.Asr(byte2, 2) and $1F;
r8 := TMathUtils.Asr(r5 * 527 + 23, 6);
g8 := TMathUtils.Asr(g5 * 527 + 23, 6);
b8 := TMathUtils.Asr(b5 * 527 + 23, 6);
// cheap, not fully accurate conversion
//pixel := (byte2 shl 8) or byte1;
//b8 := (((pixel) and $001F) shl 3);
//g8 := (((pixel) and $07E0) shr 2) and $FF;
//r8 := (((pixel) and $F800) shr 8);
luminances[luminanceIndex] := TMathUtils.Asr(RChannelWeight * r8 + GChannelWeight * g8 +
BChannelWeight * b8, ChannelWeight);
Inc(index, 2);
Inc(luminanceIndex);
end;
end;
procedure TRGBLuminanceSource.CalculateLuminanceRGB24(
const rgbRawBytes: TArray<Byte>);
var
rgbIndex,
luminanceIndex,
r, g, b : Integer;
begin
rgbIndex := 0;
luminanceIndex := 0;
while (((rgbIndex < Length(rgbRawBytes)) and
(luminanceIndex < Length(luminances)))) do
begin
// Calculate luminance cheaply, favoring green.
r := rgbRawBytes[rgbIndex];
Inc(rgbIndex);
g := rgbRawBytes[rgbIndex];
Inc(rgbIndex);
b := rgbRawBytes[rgbIndex];
Inc(rgbIndex);
luminances[luminanceIndex] := TMathUtils.Asr(RChannelWeight * r + GChannelWeight * g +
BChannelWeight * b,ChannelWeight);
inc(luminanceIndex)
end;
end;
procedure TRGBLuminanceSource.CalculateLuminanceBGR24(
const rgbRawBytes: TArray<Byte>);
var
rgbIndex,
luminanceIndex,
b, g, r : Byte;
begin
rgbIndex := 0;
luminanceIndex := 0;
while (((rgbIndex < Length(rgbRawBytes)) and
(luminanceIndex < Length(luminances)))) do
begin
// Calculate luminance cheaply, favoring green.
b := rgbRawBytes[rgbIndex];
Inc(rgbIndex);
g := rgbRawBytes[rgbIndex];
Inc(rgbIndex);
r := rgbRawBytes[rgbIndex];
Inc(rgbIndex);
luminances[luminanceIndex] := TMathUtils.Asr(RChannelWeight * r + GChannelWeight * g +
BChannelWeight * b,ChannelWeight);
Inc(luminanceIndex)
end;
end;
procedure TRGBLuminanceSource.CalculateLuminanceRGB32(
const rgbRawBytes: TArray<Byte>);
var
rgbIndex,
luminanceIndex,
r, g, b : Byte;
begin
rgbIndex := 0;
luminanceIndex := 0;
while (((rgbIndex < Length(rgbRawBytes)) and
(luminanceIndex < Length(luminances)))) do
begin
// Calculate luminance cheaply, favoring green.
r := rgbRawBytes[rgbIndex];
Inc(rgbIndex);
g := rgbRawBytes[rgbIndex];
Inc(rgbIndex);
b := rgbRawBytes[rgbIndex];
Inc(rgbIndex, 2);
luminances[luminanceIndex] := TMathUtils.Asr(RChannelWeight * r + GChannelWeight * g +
BChannelWeight * b, ChannelWeight);
Inc(luminanceIndex);
end;
end;
procedure TRGBLuminanceSource.CalculateLuminanceBGR32(
const rgbRawBytes: TArray<Byte>);
var
rgbIndex,
luminanceIndex,
b, g, r : Byte;
begin
rgbIndex := 0;
luminanceIndex := 0;
while (((rgbIndex < Length(rgbRawBytes)) and
(luminanceIndex < Length(luminances)))) do
begin
// Calculate luminance cheaply, favoring green.
b := rgbRawBytes[rgbIndex];
Inc(rgbIndex);
g := rgbRawBytes[rgbIndex];
Inc(rgbIndex);
r := rgbRawBytes[rgbIndex];
Inc(rgbIndex, 2);
luminances[luminanceIndex] := TMathUtils.Asr(RChannelWeight * r + GChannelWeight * g +
BChannelWeight * b, ChannelWeight);
Inc(luminanceIndex);
end;
end;
procedure TRGBLuminanceSource.CalculateLuminanceBGRA32(
const rgbRawBytes: TArray<Byte>);
var
rgbIndex,
luminanceIndex,
b, g, r,
alpha : Byte;
luminance : Byte;
begin
rgbIndex := 0;
luminanceIndex := 0;
while (((rgbIndex < Length(rgbRawBytes)) and
(luminanceIndex < Length(luminances)))) do
begin
// Calculate luminance cheaply, favoring green.
b := rgbRawBytes[rgbIndex];
Inc(rgbIndex);
g := rgbRawBytes[rgbIndex];
Inc(rgbIndex);
r := rgbRawBytes[rgbIndex];
Inc(rgbIndex);
alpha := rgbRawBytes[rgbIndex];
Inc(rgbIndex);
luminance := TMathUtils.Asr(RChannelWeight * r + GChannelWeight * g +
BChannelWeight * b, ChannelWeight);
luminances[luminanceIndex] := (TMathUtils.Asr(luminance * alpha, 8) + TMathUtils.Asr(255 * (255 - alpha), 8));
Inc(luminanceIndex);
end;
end;
procedure TRGBLuminanceSource.CalculateLuminanceRGBA32(
const rgbRawBytes: TArray<Byte>);
var
rgbIndex,
luminanceIndex,
r, g, b,
alpha : Byte;
luminance : Byte;
begin
rgbIndex := 0;
luminanceIndex := 0;
while (((rgbIndex < Length(rgbRawBytes)) and
(luminanceIndex < Length(luminances)))) do
begin
// Calculate luminance cheaply, favoring green.
r := rgbRawBytes[rgbIndex];
Inc(rgbIndex);
g := rgbRawBytes[rgbIndex];
Inc(rgbIndex);
b := rgbRawBytes[rgbIndex];
Inc(rgbIndex);
alpha := rgbRawBytes[rgbIndex];
Inc(rgbIndex);
luminance := TMathUtils.Asr(RChannelWeight * r + GChannelWeight * g +
BChannelWeight * b, ChannelWeight);
luminances[luminanceIndex] := TMathUtils.Asr(luminance * alpha, 8) + TMathUtils.Asr(255 * (255 - alpha), 8);
Inc(luminanceIndex);
end;
end;
procedure TRGBLuminanceSource.CalculateLuminanceARGB32(
const rgbRawBytes: TArray<Byte>);
var
rgbIndex,
luminanceIndex,
r, g, b,
alpha : Byte;
luminance : Byte;
begin
rgbIndex := 0;
luminanceIndex := 0;
while (((rgbIndex < Length(rgbRawBytes)) and
(luminanceIndex < Length(luminances)))) do
begin
// Calculate luminance cheaply, favoring green.
alpha := rgbRawBytes[rgbIndex];
Inc(rgbIndex);
r := rgbRawBytes[rgbIndex];
Inc(rgbIndex);
g := rgbRawBytes[rgbIndex];
Inc(rgbIndex);
b := rgbRawBytes[rgbIndex];
Inc(rgbIndex);
luminance := TMathUtils.Asr(RChannelWeight * r + GChannelWeight * g +
BChannelWeight * b, ChannelWeight);
luminances[luminanceIndex] := TMathUtils.Asr(luminance * alpha,8) + TMathUtils.Asr(255 * (255 - alpha),8);
Inc(luminanceIndex);
end;
end;
function TRGBLuminanceSource.GetBitmapFormat: TBitmapFormat;
begin
try
Result := DetermineBitmapFormat(luminances, Width, Height);
except
Result := TBitmapFormat.Unknown;
end;
end;
end.
+202
View File
@@ -0,0 +1,202 @@
Apache License
Version 2.0, January 2004
http://www.apache.org/licenses/
TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION
1. Definitions.
"License" shall mean the terms and conditions for use, reproduction,
and distribution as defined by Sections 1 through 9 of this document.
"Licensor" shall mean the copyright owner or entity authorized by
the copyright owner that is granting the License.
"Legal Entity" shall mean the union of the acting entity and all
other entities that control, are controlled by, or are under common
control with that entity. For the purposes of this definition,
"control" means (i) the power, direct or indirect, to cause the
direction or management of such entity, whether by contract or
otherwise, or (ii) ownership of fifty percent (50%) or more of the
outstanding shares, or (iii) beneficial ownership of such entity.
"You" (or "Your") shall mean an individual or Legal Entity
exercising permissions granted by this License.
"Source" form shall mean the preferred form for making modifications,
including but not limited to software source code, documentation
source, and configuration files.
"Object" form shall mean any form resulting from mechanical
transformation or translation of a Source form, including but
not limited to compiled object code, generated documentation,
and conversions to other media types.
"Work" shall mean the work of authorship, whether in Source or
Object form, made available under the License, as indicated by a
copyright notice that is included in or attached to the work
(an example is provided in the Appendix below).
"Derivative Works" shall mean any work, whether in Source or Object
form, that is based on (or derived from) the Work and for which the
editorial revisions, annotations, elaborations, or other modifications
represent, as a whole, an original work of authorship. For the purposes
of this License, Derivative Works shall not include works that remain
separable from, or merely link (or bind by name) to the interfaces of,
the Work and Derivative Works thereof.
"Contribution" shall mean any work of authorship, including
the original version of the Work and any modifications or additions
to that Work or Derivative Works thereof, that is intentionally
submitted to Licensor for inclusion in the Work by the copyright owner
or by an individual or Legal Entity authorized to submit on behalf of
the copyright owner. For the purposes of this definition, "submitted"
means any form of electronic, verbal, or written communication sent
to the Licensor or its representatives, including but not limited to
communication on electronic mailing lists, source code control systems,
and issue tracking systems that are managed by, or on behalf of, the
Licensor for the purpose of discussing and improving the Work, but
excluding communication that is conspicuously marked or otherwise
designated in writing by the copyright owner as "Not a Contribution."
"Contributor" shall mean Licensor and any individual or Legal Entity
on behalf of whom a Contribution has been received by Licensor and
subsequently incorporated within the Work.
2. Grant of Copyright License. Subject to the terms and conditions of
this License, each Contributor hereby grants to You a perpetual,
worldwide, non-exclusive, no-charge, royalty-free, irrevocable
copyright license to reproduce, prepare Derivative Works of,
publicly display, publicly perform, sublicense, and distribute the
Work and such Derivative Works in Source or Object form.
3. Grant of Patent License. Subject to the terms and conditions of
this License, each Contributor hereby grants to You a perpetual,
worldwide, non-exclusive, no-charge, royalty-free, irrevocable
(except as stated in this section) patent license to make, have made,
use, offer to sell, sell, import, and otherwise transfer the Work,
where such license applies only to those patent claims licensable
by such Contributor that are necessarily infringed by their
Contribution(s) alone or by combination of their Contribution(s)
with the Work to which such Contribution(s) was submitted. If You
institute patent litigation against any entity (including a
cross-claim or counterclaim in a lawsuit) alleging that the Work
or a Contribution incorporated within the Work constitutes direct
or contributory patent infringement, then any patent licenses
granted to You under this License for that Work shall terminate
as of the date such litigation is filed.
4. Redistribution. You may reproduce and distribute copies of the
Work or Derivative Works thereof in any medium, with or without
modifications, and in Source or Object form, provided that You
meet the following conditions:
(a) You must give any other recipients of the Work or
Derivative Works a copy of this License; and
(b) You must cause any modified files to carry prominent notices
stating that You changed the files; and
(c) You must retain, in the Source form of any Derivative Works
that You distribute, all copyright, patent, trademark, and
attribution notices from the Source form of the Work,
excluding those notices that do not pertain to any part of
the Derivative Works; and
(d) If the Work includes a "NOTICE" text file as part of its
distribution, then any Derivative Works that You distribute must
include a readable copy of the attribution notices contained
within such NOTICE file, excluding those notices that do not
pertain to any part of the Derivative Works, in at least one
of the following places: within a NOTICE text file distributed
as part of the Derivative Works; within the Source form or
documentation, if provided along with the Derivative Works; or,
within a display generated by the Derivative Works, if and
wherever such third-party notices normally appear. The contents
of the NOTICE file are for informational purposes only and
do not modify the License. You may add Your own attribution
notices within Derivative Works that You distribute, alongside
or as an addendum to the NOTICE text from the Work, provided
that such additional attribution notices cannot be construed
as modifying the License.
You may add Your own copyright statement to Your modifications and
may provide additional or different license terms and conditions
for use, reproduction, or distribution of Your modifications, or
for any such Derivative Works as a whole, provided Your use,
reproduction, and distribution of the Work otherwise complies with
the conditions stated in this License.
5. Submission of Contributions. Unless You explicitly state otherwise,
any Contribution intentionally submitted for inclusion in the Work
by You to the Licensor shall be under the terms and conditions of
this License, without any additional terms or conditions.
Notwithstanding the above, nothing herein shall supersede or modify
the terms of any separate license agreement you may have executed
with Licensor regarding such Contributions.
6. Trademarks. This License does not grant permission to use the trade
names, trademarks, service marks, or product names of the Licensor,
except as required for reasonable and customary use in describing the
origin of the Work and reproducing the content of the NOTICE file.
7. Disclaimer of Warranty. Unless required by applicable law or
agreed to in writing, Licensor provides the Work (and each
Contributor provides its Contributions) on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or
implied, including, without limitation, any warranties or conditions
of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A
PARTICULAR PURPOSE. You are solely responsible for determining the
appropriateness of using or redistributing the Work and assume any
risks associated with Your exercise of permissions under this License.
8. Limitation of Liability. In no event and under no legal theory,
whether in tort (including negligence), contract, or otherwise,
unless required by applicable law (such as deliberate and grossly
negligent acts) or agreed to in writing, shall any Contributor be
liable to You for damages, including any direct, indirect, special,
incidental, or consequential damages of any character arising as a
result of this License or out of the use or inability to use the
Work (including but not limited to damages for loss of goodwill,
work stoppage, computer failure or malfunction, or any and all
other commercial damages or losses), even if such Contributor
has been advised of the possibility of such damages.
9. Accepting Warranty or Additional Liability. While redistributing
the Work or Derivative Works thereof, You may choose to offer,
and charge a fee for, acceptance of support, warranty, indemnity,
or other liability obligations and/or rights consistent with this
License. However, in accepting such obligations, You may act only
on Your own behalf and on Your sole responsibility, not on behalf
of any other Contributor, and only if You agree to indemnify,
defend, and hold each Contributor harmless for any liability
incurred by, or claims asserted against, such Contributor by reason
of your accepting any such warranty or additional liability.
END OF TERMS AND CONDITIONS
APPENDIX: How to apply the Apache License to your work.
To apply the Apache License to your work, attach the following
boilerplate notice, with the fields enclosed by brackets "{}"
replaced with your own identifying information. (Don't include
the brackets!) The text should be enclosed in the appropriate
comment syntax for the file format. We also recommend that a
file or class name and description of purpose be included on the
same "printed page" as the copyright notice for easier
identification within third-party archives.
Copyright {yyyy} {name of copyright owner}
Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
+185
View File
@@ -0,0 +1,185 @@
unit ZXing.ScanManager;
interface
uses
System.SysUtils,
System.Generics.Collections,
{$IFDEF FRAMEWORK_FMX}
FMX.Graphics,
{$ENDIF}
{$IFDEF FRAMEWORK_VCL}
VCL.Graphics,
{$ENDIF}
ZXing.LuminanceSource,
ZXing.RGBLuminanceSource,
ZXing.InvertedLuminanceSource,
ZXing.HybridBinarizer,
ZXing.BinaryBitmap,
ZXing.MultiFormatReader,
ZXing.BarcodeFormat,
ZXing.ResultPoint,
ZXing.ReadResult,
ZXing.DecodeHintType;
type
TScanManager = class
private
FEnableInversion: Boolean;
FHints: TDictionary<TDecodeHintType, TObject>;
FResultPointEvent: TResultPointCallback;
FMultiFormatReader: TMultiFormatReader;
listFormats: TList<TBarcodeFormat>;
function GetMultiFormatReader(const format: TBarcodeFormat)
: TMultiFormatReader;
procedure SetResultPointEvent(const AValue: TResultPointCallback);
public
destructor Destroy; override;
function Scan(const pBitmapForScan: TBitmap): TReadResult;
constructor Create(const format: TBarcodeFormat;
Hints: TDictionary<TDecodeHintType, TObject>);
property OnResultPoint: TResultPointCallback read FResultPointEvent
write SetResultPointEvent;
end;
implementation
constructor TScanManager.Create(const format: TBarcodeFormat;
Hints: TDictionary<TDecodeHintType, TObject>);
begin
inherited Create;
FEnableInversion := False;
FHints := Hints;
FMultiFormatReader := GetMultiFormatReader(format);
end;
destructor TScanManager.Destroy;
var
hint: TPair<TDecodeHintType, TObject>;
o: TObject;
begin
if Assigned(FHints) then
begin
for hint in FHints do
begin
o := hint.Value;
if Assigned(o) then
o.Free;
end;
FHints.Clear();
FreeAndNil(FHints);
end;
FreeAndNil(FMultiFormatReader);
inherited;
end;
procedure TScanManager.SetResultPointEvent(const AValue: TResultPointCallback);
var
ahKey: TDecodeHintType;
ahValue: TObject;
begin
FResultPointEvent := AValue;
ahKey := TDecodeHintType.NEED_RESULT_POINT_CALLBACK;
if Assigned(FResultPointEvent) then
begin
ahValue := TResultPointEventObject.Create(FResultPointEvent);
FHints.AddOrSetValue(ahKey, ahValue);
end
else
begin
if Fhints.TryGetValue(ahKey, ahValue) then
begin
ahValue.Free;
ahValue := nil;
FHints.Remove(ahKey);
end;
end;
end;
function TScanManager.GetMultiFormatReader(const format: TBarcodeFormat)
: TMultiFormatReader;
var
o: TObject;
begin
Result := TMultiFormatReader.Create;
listFormats := nil;
if FHints = nil then
FHints := TDictionary<TDecodeHintType, TObject>.Create();
if FHints.ContainsKey(ZXing.DecodeHintType.ENABLE_INVERSION) then
FEnableInversion := true;
if format <> TBarcodeFormat.Auto then
begin
if (FHints.TryGetValue(ZXing.DecodeHintType.POSSIBLE_FORMATS, o)) then
listFormats := o as TList<TBarcodeFormat>
else
begin
listFormats := TList<TBarcodeFormat>.Create();
FHints.Add(ZXing.DecodeHintType.POSSIBLE_FORMATS, listFormats);
end;
if (listFormats.Count = 0) then
listFormats.Add(format)
else
listFormats.Insert(0, format); // favor the format parameter
end;
Result.Hints := FHints;
end;
function TScanManager.Scan(const pBitmapForScan: TBitmap): TReadResult;
var
LuminanceSource, InvLuminanceSource: TLuminanceSource;
HybridBinarizer: THybridBinarizer;
BinaryBitmap: TBinaryBitmap;
begin
InvLuminanceSource := nil;
LuminanceSource := nil;
HybridBinarizer := nil;
BinaryBitmap := nil;
try
LuminanceSource := TRGBLuminanceSource.CreateFromBitmap(pBitmapForScan,
pBitmapForScan.Width, pBitmapForScan.Height);
HybridBinarizer := THybridBinarizer.Create(LuminanceSource);
BinaryBitmap := TBinaryBitmap.Create(HybridBinarizer);
Result := FMultiFormatReader.Decode(BinaryBitmap, true);
if (Result = nil) then
begin
if (FEnableInversion) then
begin
if (BinaryBitmap <> nil) then
FreeAndNil(BinaryBitmap);
if (HybridBinarizer <> nil) then
FreeAndNil(HybridBinarizer);
InvLuminanceSource := LuminanceSource.invert();
HybridBinarizer := THybridBinarizer.Create(InvLuminanceSource);
BinaryBitmap := TBinaryBitmap.Create(HybridBinarizer);
Result := FMultiFormatReader.Decode(BinaryBitmap, true);
end;
end;
finally
BinaryBitmap.Free;
HybridBinarizer.Free;
InvLuminanceSource.Free;
LuminanceSource.Free;
end;
end;
end.
+9
View File
@@ -70,6 +70,15 @@ $log | Select-String -Pattern 'lines,' | ForEach-Object { $_.Line.Trim() }
New-Item -ItemType Directory -Force -Path "$stage", New-Item -ItemType Directory -Force -Path "$stage",
"$stage\classes", "$stage\library\lib\arm64-v8a" | Out-Null "$stage\classes", "$stage\library\lib\arm64-v8a" | Out-Null
Copy-Item "$out\AndroidManifest.xml" "$stage\AndroidManifest.xml" -Force Copy-Item "$out\AndroidManifest.xml" "$stage\AndroidManifest.xml" -Force
# DELPHI MET android:debuggable="true" MEME EN RELEASE, et l'APK livre le
# portait. Sur un telephone ou le debogage USB est actif, `adb run-as` ouvre
# alors le dossier prive de l'application - donc vault.bin et les reglages -
# sans acces root. On le force a faux pour une release, et seulement la.
if ($Release) {
$mf = Get-Content "$stage\AndroidManifest.xml" -Raw
$mf = $mf -replace 'android:debuggable="true"', 'android:debuggable="false"'
Set-Content "$stage\AndroidManifest.xml" -Value $mf -Encoding utf8
}
Copy-Item "$out\pmserverApk.classes\*.dex" "$stage\classes\" -Force Copy-Item "$out\pmserverApk.classes\*.dex" "$stage\classes\" -Force
& $strip --strip-debug -o "$stage\library\lib\arm64-v8a\libpmserverApk.so" "$out\libpmserverApk.so" & $strip --strip-debug -o "$stage\library\lib\arm64-v8a\libpmserverApk.so" "$out\libpmserverApk.so"
+8 -3
View File
@@ -7,7 +7,7 @@
# ne peuvent y arriver autrement. On laisse Deploy faire son travail, puis on # ne peuvent y arriver autrement. On laisse Deploy faire son travail, puis on
# remet ce qu'il a efface et on refait aapt / zipalign / signature. # remet ce qu'il a efface et on refait aapt / zipalign / signature.
# #
# A lancer depuis la racine du depot, apres un Deploy reussi. # A lancer apres un Deploy reussi, depuis n'importe quel dossier.
# #
# -Config Release empaquette la sortie Release au lieu de Debug # -Config Release empaquette la sortie Release au lieu de Debug
# -Keystore <chemin> -Alias signe avec CETTE cle au lieu de celle de debogage # -Keystore <chemin> -Alias signe avec CETTE cle au lieu de celle de debogage
@@ -30,7 +30,12 @@ $sdk = 'C:\Users\Public\Documents\Embarcadero\Studio\23.0\CatalogRepository\And
$bds = 'C:\Program Files (x86)\Embarcadero\Studio\23.0' $bds = 'C:\Program Files (x86)\Embarcadero\Studio\23.0'
$jdk = 'C:\Program Files\Eclipse Adoptium\jdk-11.0.15.10-hotspot' $jdk = 'C:\Program Files\Eclipse Adoptium\jdk-11.0.15.10-hotspot'
$pac = "$bds\bin\paclient.exe" $pac = "$bds\bin\paclient.exe"
$p = ".\Android64\$Config\pmserverApk" # ANCRE SUR LE DEPOT, PAS SUR LE DOSSIER COURANT. Ces chemins etaient relatifs
# (".\Android64\...") : lance depuis ailleurs que la racine, le script
# empaquetait un dossier qui n'existait pas et semait des copies de ressources
# dans le repertoire courant — la compilation, elle, allait bien au depot.
$repo = Split-Path $PSScriptRoot -Parent
$p = "$repo\Android64\$Config\pmserverApk"
# 0. LES RESSOURCES QUE LA COMPILATION GENERE, MISES EN PLACE A LA MAIN. # 0. LES RESSOURCES QUE LA COMPILATION GENERE, MISES EN PLACE A LA MAIN.
# #
@@ -62,7 +67,7 @@ $genRes = @{
'splash_image_def.xml' = 'drawable\splash_image_def.xml' 'splash_image_def.xml' = 'drawable\splash_image_def.xml'
'splash_image_def-v21.xml'= 'drawable-anydpi-v21\splash_image_def.xml' 'splash_image_def-v21.xml'= 'drawable-anydpi-v21\splash_image_def.xml'
} }
$outDir = ".\Android64\$Config" $outDir = "$repo\Android64\$Config"
foreach ($k in $genRes.Keys) { foreach ($k in $genRes.Keys) {
$src = "$outDir\$k" $src = "$outDir\$k"
if (-not (Test-Path $src)) { continue } # Delphi ne genere pas tout partout if (-not (Test-Path $src)) { continue } # Delphi ne genere pas tout partout
+291 -58
View File
@@ -161,6 +161,11 @@
.btn:active { opacity: .62; } .btn:active { opacity: .62; }
.btn.wide { padding: 13px 18px; font-size: 15px; } .btn.wide { padding: 13px 18px; font-size: 15px; }
.btn.main { background: var(--accent); } .btn.main { background: var(--accent); }
.btn:disabled { opacity: .45; }
.opt { display: flex; gap: 12px; align-items: center; margin: 10px 4px;
font-size: 15px; }
.opt input { width: 22px; height: 22px; accent-color: #22d3ee; flex: none; }
.field-in:disabled { opacity: .5; }
/* Rouge sourd : assez pour qu'on ne le confonde pas avec Copy, pas assez /* Rouge sourd : assez pour qu'on ne le confonde pas avec Copy, pas assez
pour attirer l'oeil sur la seule action irreversible de l'ecran. */ pour attirer l'oeil sur la seule action irreversible de l'ecran. */
.btn.danger { background: rgba(220, 80, 80, .30); } .btn.danger { background: rgba(220, 80, 80, .30); }
@@ -177,6 +182,9 @@
besoin d'etre visible pour exister. */ besoin d'etre visible pour exister. */
background: none; } background: none; }
.btn.ico-btn svg { width: 22px; height: 22px; } .btn.ico-btn svg { width: 22px; height: 22px; }
/* LA FLECHE DE RETOUR, EN GRAND : c'est le geste le plus frequent de
l'app, et un caractere fleche de police restait minuscule. */
.btn.back-btn svg { width: 30px; height: 30px; }
/* Le retour d'appui ne peut plus venir du fond : il vient du trait. */ /* Le retour d'appui ne peut plus venir du fond : il vient du trait. */
.btn.ico-btn:active { opacity: .45; } .btn.ico-btn:active { opacity: .45; }
/* Le point des modifications en attente. Sur le cadenas parce qu'il est /* Le point des modifications en attente. Sur le cadenas parce qu'il est
@@ -276,7 +284,7 @@
/* UN REFUS N'EST PAS UN ETAT. "Master password: 8 characters at least" se /* UN REFUS N'EST PAS UN ETAT. "Master password: 8 characters at least" se
lisait du meme gris que "Vault on this device" - on ne voyait pas que lisait du meme gris que "Vault on this device" - on ne voyait pas que
l'application venait de refuser quelque chose. */ l'application venait de refuser quelque chose. */
.status.err { color: #ff9d9d; } .status.err, .sheet .note.err { color: #ff9d9d; }
.stack { display: flex; flex-direction: column; gap: 8px; } .stack { display: flex; flex-direction: column; gap: 8px; }
/* L'espace de 8 px vit A L'INTERIEUR de chaque pile. Deux piles voisines se /* L'espace de 8 px vit A L'INTERIEUR de chaque pile. Deux piles voisines se
touchaient donc, et "Create vault" collait a "Download vault" alors que touchaient donc, et "Create vault" collait a "Download vault" alors que
@@ -296,7 +304,13 @@
border: 0; border-radius: var(--radius-s); border: 0; border-radius: var(--radius-s);
background: rgba(255,255,255,.10); color: var(--text); background: rgba(255,255,255,.10); color: var(--text);
font: inherit; outline: none; font: inherit; outline: none;
/* Le body interdit la selection (user-select: none) et les champs en
HERITAIENT : le curseur ne suivait pas le doigt et le texte ne defilait
jamais - la fin d'une URL longue restait hors d'atteinte. */
-webkit-user-select: text; user-select: text;
} }
.field-in.multi { height: auto; min-height: 46px; overflow: hidden; padding: 12px 44px 12px 14px; resize: none;
line-height: 1.35; word-break: break-all; display: block; }
.field-in::placeholder { color: var(--muted); } .field-in::placeholder { color: var(--muted); }
/* La fleche dit si le panneau est deplie, et de quel bouton il descend. */ /* La fleche dit si le panneau est deplie, et de quel bouton il descend. */
.chev { display: inline-block; margin-left: 6px; font-size: 11px; .chev { display: inline-block; margin-left: 6px; font-size: 11px;
@@ -316,7 +330,10 @@
des que le margin disparaissait. Le bord INFERIEUR, lui, est celui que le des que le margin disparaissait. Le bord INFERIEUR, lui, est celui que le
champ touche dans les deux cas - le margin est au-dessus. */ champ touche dans les deux cas - le margin est au-dessus. */
.in-x { .in-x {
position: absolute; right: 0; bottom: 0; width: 44px; height: 46px; /* 32 px pour 44 px de marge : les 12 px entre le texte et la croix
recoivent le toucher, qui pose le curseur en fin de texte au lieu
d'effacer le champ. */
position: absolute; right: 0; bottom: 0; width: 32px; height: 46px;
display: flex; align-items: center; justify-content: center; display: flex; align-items: center; justify-content: center;
color: var(--muted); font-size: 22px; color: var(--muted); font-size: 22px;
} }
@@ -395,6 +412,9 @@
<div class="stack"> <div class="stack">
<button class="btn wide main" id="btnOpen">&#10140;&nbsp; Open vault</button> <button class="btn wide main" id="btnOpen">&#10140;&nbsp; Open vault</button>
<!-- LA SORTIE DE SECOURS DU VERROUILLAGE D'ECRAN : empreinte refusee,
schema oublie - le mot de passe du coffre ouvre toujours. -->
<button class="btn wide" id="btnUsePwd" hidden>Use the vault password</button>
<button class="btn wide" id="btnSync">&#8635;&nbsp; Sync</button> <button class="btn wide" id="btnSync">&#8635;&nbsp; Sync</button>
<!-- UN SEUL BOUTON, ET IL NE MENT PAS SUR SA DESTINATION. <!-- UN SEUL BOUTON, ET IL NE MENT PAS SUR SA DESTINATION.
Il y en avait deux, "Settings" et "Log", et le second a fini par Il y en avait deux, "Settings" et "Log", et le second a fini par
@@ -537,7 +557,7 @@
<div class="screen" id="detail"> <div class="screen" id="detail">
<div class="head"> <div class="head">
<button class="btn" id="back">&#8592;</button> <button class="btn ico-btn back-btn" id="back"><svg viewBox="0 0 24 24" fill="none" stroke="currentColor" stroke-width="2.4" stroke-linecap="round" stroke-linejoin="round" aria-label="Back" role="img"><path d="M20 12H5M11 5l-7 7 7 7"/></svg></button>
<h1 id="dtitle"></h1> <h1 id="dtitle"></h1>
<button class="btn ico-btn" id="kebab" aria-label="Entry menu"></button> <button class="btn ico-btn" id="kebab" aria-label="Entry menu"></button>
</div> </div>
@@ -551,15 +571,20 @@
nature differente sur l'ecran ou l'on veut surtout ouvrir son coffre. --> nature differente sur l'ecran ou l'on veut surtout ouvrir son coffre. -->
<div class="sheet" id="settings"> <div class="sheet" id="settings">
<div class="head"> <div class="head">
<button class="btn" id="setBack">&#8592;</button> <button class="btn ico-btn back-btn" id="setBack"><svg viewBox="0 0 24 24" fill="none" stroke="currentColor" stroke-width="2.4" stroke-linecap="round" stroke-linejoin="round" aria-label="Back" role="img"><path d="M20 12H5M11 5l-7 7 7 7"/></svg></button>
<h1>Settings</h1> <h1>Settings</h1>
</div> </div>
<div class="scroll"> <div class="scroll">
<h2>Repository</h2> <h2>Repository</h2>
<div class="note err" id="sRepoErr" hidden></div>
<div class="in-wrap"> <div class="in-wrap">
<input class="field-in" id="sUrl" placeholder="endpoint URL" <!-- ZONE DE TEXTE ET NON input : l'URL passe a la ligne et se lit en
entier. Un input d'une ligne ne defilait pas sous le doigt dans la
WebView de l'app, et la fin d'une URL d'API restait inatteignable. -->
<textarea class="field-in multi" id="sUrl" rows="1"
placeholder="repository URL - Gitea or github.com/owner/repo (private)"
autocomplete="off" autocorrect="off" autocapitalize="none" autocomplete="off" autocorrect="off" autocapitalize="none"
spellcheck="false" inputmode="url"> spellcheck="false" inputmode="url"></textarea>
<div class="in-x" data-clear="sUrl">&#215;</div> <div class="in-x" data-clear="sUrl">&#215;</div>
</div> </div>
<div class="in-wrap"> <div class="in-wrap">
@@ -572,35 +597,49 @@
type="password" autocomplete="off"> type="password" autocomplete="off">
<div class="in-x" data-clear="sPwd">&#215;</div> <div class="in-x" data-clear="sPwd">&#215;</div>
</div> </div>
<button class="btn wide" id="sScan">Scan the QR shown on the PC</button>
<button class="btn wide" id="sSave" disabled>Save</button>
<div class="note">The sync password never leaves this device. It is what <div class="note">The sync password never leaves this device. It is what
encrypts the copy kept in the repository, so it must be the same on every encrypts the copy kept in the repository, so it must be the same on every
device that shares it; the token only opens the repository. It is not the device that shares it; the token only opens the repository. It is asked
password that opens a vault created on this phone - that one is asked for for once: afterwards the vault opens with the phone screen lock, an app
on the home screen.</div> code, or this password - your choice, under <b>Unlock with</b><span
id="sUnlockHint"></span>.</div>
<!-- COFFRE FERME, SECTION CACHEE. Poser comme retirer un code exigent le <!-- COFFRE FERME, SECTION CACHEE. Poser comme retirer un code exigent le
clair en main : les deux ne pourraient que refuser, et proposer une clair en main : les deux ne pourraient que refuser, et proposer une
action qui refuse toujours vaut moins que ne rien proposer. --> action qui refuse toujours vaut moins que ne rien proposer. -->
<div id="secCode" hidden> <div id="secCode" hidden>
<h2>Unlock code</h2> <h2>Unlock with</h2>
<!-- TROIS FACONS D'OUVRIR, UNE SEULE COPIE LOCALE. Le coffre lui-meme n'est
jamais touche : seul le scellement de la copie rapide change. Le champ
sert a tout - nouveau code, mot de passe du coffre, ou code courant
pour revenir au verrouillage d'ecran (retirer une protection demande
de la connaitre). -->
<div class="in-wrap"> <div class="in-wrap">
<input class="field-in" id="sPinNew" placeholder="new unlock code or password" <input class="field-in" id="sPinNew" placeholder="code or password"
type="password" autocomplete="off"> type="password" autocomplete="off">
<div class="in-x" data-clear="sPinNew">&#215;</div> <div class="in-x" data-clear="sPinNew">&#215;</div>
</div> </div>
<button class="btn wide" id="sPinSet">Set this code</button> <button class="btn wide" id="sModeDevice">Screen lock (fingerprint, pattern...)</button>
<!-- Le champ ci-dessus sert aux deux : le NOUVEAU code pour "Set", le code <button class="btn wide" id="sModeCode">App code (type it above)</button>
COURANT pour "Remove". Retirer une protection demande de la connaitre, <button class="btn wide" id="sModePwd">Vault password (type it above)</button>
sinon quiconque trouve le telephone ouvert la leve en deux appuis. --> <div class="note" id="sModeNote"></div>
<button class="btn wide danger" id="sPinClear">Remove the unlock code</button>
<div class="note">To remove the code, type the current one above first.
The code seals the copy kept on this device. It can be
digits or a full password - a longer one is harder to guess, and it is
asked for only when the vault opens. Removing it leaves the vault
readable by anyone holding the phone unlocked.</div>
</div> </div>
<h2>Diagnostics</h2> <!-- LE TITRE SUIT SON BOUTON : sans lui, une release affichait
"Diagnostics" au-dessus de rien. -->
<h2>Copy and search</h2>
<label class="opt"><input type="checkbox" id="sBack">
Hide Vault after copying (may show the home screen)</label>
<label class="opt"><input type="checkbox" id="sKbd">
Open the keyboard on the search when the vault opens</label>
<div class="note">To jump back to the app you came from, use Android's own
gesture: swipe along the bottom bar, or tap the recent-apps button twice.
After a copy the vault stays open for 2 minutes in the background, time
to paste the username and come back for the password.</div>
<h2 id="sDiagH">Diagnostics</h2>
<button class="btn wide" id="sLog">Show the log</button> <button class="btn wide" id="sLog">Show the log</button>
<!-- LE JOURNAL EST ICI, PAS SUR L'ACCUEIL. Il y vivait, et depuis que les <!-- LE JOURNAL EST ICI, PAS SUR L'ACCUEIL. Il y vivait, et depuis que les
reglages sont un ecran on l'y atteignait par un bouton qui refermait reglages sont un ecran on l'y atteignait par un bouton qui refermait
@@ -633,7 +672,7 @@
apres qu'on a fini de les lire. --> apres qu'on a fini de les lire. -->
<div class="sheet" id="history"> <div class="sheet" id="history">
<div class="head"> <div class="head">
<button class="btn" id="histBack">&#8592;</button> <button class="btn ico-btn back-btn" id="histBack"><svg viewBox="0 0 24 24" fill="none" stroke="currentColor" stroke-width="2.4" stroke-linecap="round" stroke-linejoin="round" aria-label="Back" role="img"><path d="M20 12H5M11 5l-7 7 7 7"/></svg></button>
<h1>Previous passwords</h1> <h1>Previous passwords</h1>
</div> </div>
<div class="scroll"><div id="histBody"></div></div> <div class="scroll"><div id="histBody"></div></div>
@@ -722,7 +761,8 @@ var vaultOpen = false;
// en dernier - c'est l'ordre des frequences, pas celui du code. La creation // en dernier - c'est l'ordre des frequences, pas celui du code. La creation
// etait en tete parce que son bloc etait ecrit en premier dans la page. // etait en tete parce que son bloc etait ecrit en premier dans la page.
function syncAuthbox() { function syncAuthbox() {
document.getElementById('authbox').hidden = (authMode === 'open'); document.getElementById('authbox').hidden =
(authMode === 'open') || (authMode === 'download');
// L'ACCENT SUIT LE GESTE ATTENDU. Creer un coffre neuf le portait alors qu'un // L'ACCENT SUIT LE GESTE ATTENDU. Creer un coffre neuf le portait alors qu'un
// depot est configure - c'est-a-dire exactement le mauvais geste. Il revient // depot est configure - c'est-a-dire exactement le mauvais geste. Il revient
// a celui qui vient chercher le coffre, et ne reste sur la creation que // a celui qui vient chercher le coffre, et ne reste sur la creation que
@@ -762,6 +802,8 @@ document.getElementById('settings').addEventListener('click', function (ev) {
if (!id) return; if (!id) return;
var el = document.getElementById(id); var el = document.getElementById(id);
el.value = ''; el.value = '';
if (el.classList.contains('multi')) autoGrow(el);
syncSaveBtn(false);
el.focus(); el.focus();
}); });
@@ -877,6 +919,10 @@ function renderRows() {
+ (e.sub ? '<span>' + esc(e.sub) + '</span>' : '') + '</div>' + (e.sub ? '<span>' + esc(e.sub) + '</span>' : '') + '</div>'
+ (e.hasUser ? '<button class="btn ico-btn" data-copy="user">' + (e.hasUser ? '<button class="btn ico-btn" data-copy="user">'
+ ico('user', 'Copy username') + '</button>' : '') + ico('user', 'Copy username') + '</button>' : '')
// LE CODE 2FA A PORTEE DE POUCE, comme l'identifiant et le mot de
// passe : il fallait ouvrir l'entree pour le copier.
+ (e.hasTotp ? '<button class="btn ico-btn" data-copy="rtotp">'
+ ico('clock', 'Copy 2FA code') + '</button>' : '')
+ '<button class="btn ico-btn" data-copy="pwd">' + '<button class="btn ico-btn" data-copy="pwd">'
+ (e.isNote ? ico('note', 'Copy text') : ico('key', 'Copy password')) + (e.isNote ? ico('note', 'Copy text') : ico('key', 'Copy password'))
+ '</button></div>'; + '</button></div>';
@@ -959,6 +1005,10 @@ var ICONS = {
dots: '<circle cx="12" cy="5" r="1.4"/><circle cx="12" cy="12" r="1.4"/>' dots: '<circle cx="12" cy="5" r="1.4"/><circle cx="12" cy="12" r="1.4"/>'
+ '<circle cx="12" cy="19" r="1.4"/>', + '<circle cx="12" cy="19" r="1.4"/>',
check: '<path d="M4 12.5l5.5 5.5L20 7"/>', check: '<path d="M4 12.5l5.5 5.5L20 7"/>',
clock: '<circle cx="12" cy="12" r="8.5"/><path d="M12 7.5V12l3 2"/>',
dice: '<rect x="4" y="4" width="16" height="16" rx="3"/>'
+ '<circle cx="9" cy="9" r="1.2"/><circle cx="15" cy="15" r="1.2"/>'
+ '<circle cx="15" cy="9" r="1.2"/><circle cx="9" cy="15" r="1.2"/>',
close: '<path d="M6 6l12 12M18 6L6 18"/>', close: '<path d="M6 6l12 12M18 6L6 18"/>',
// Un arc, pas un cercle : c'est l'ouverture qui rend la rotation visible. // Un arc, pas un cercle : c'est l'ouverture qui rend la rotation visible.
loader: '<path d="M12 3a9 9 0 019 9"/>', loader: '<path d="M12 3a9 9 0 019 9"/>',
@@ -1029,6 +1079,15 @@ document.getElementById('fields').addEventListener('click', function (ev) {
// Meme raison que dans la liste : le dessin recoit l'appui, le bouton porte // Meme raison que dans la liste : le dessin recoit l'appui, le bouton porte
// l'intention. Tout ce qui suit lit et ecrit sur le bouton. // l'intention. Tout ce qui suit lit et ecrit sur le bouton.
var t = ev.target.closest('button') || ev.target; var t = ev.target.closest('button') || ev.target;
var gen = t.getAttribute('data-gen');
if (gen) {
// Visible une fois tire : on garde ce qu'on voit, pas une suite de points.
var gi = document.getElementById(gen);
gi.value = genPassword(20);
gi.type = 'text';
send('touch');
return;
}
var k = t.getAttribute('data-show'); var k = t.getAttribute('data-show');
if (k !== null) { if (k !== null) {
var cell = document.querySelector('[data-v="' + k + '"]'); var cell = document.querySelector('[data-v="' + k + '"]');
@@ -1185,6 +1244,7 @@ function openEditor(k) {
var line = row.parentNode; var line = row.parentNode;
line.classList.toggle('wrap', !!detailRows[k].m); line.classList.toggle('wrap', !!detailRows[k].m);
line.innerHTML = editorControl(k) line.innerHTML = editorControl(k)
+ (editField === 'password' ? genButton('editval') : '')
// Show n'a de sens que sur un champ masque. Sur un site en clair il // Show n'a de sens que sur un champ masque. Sur un site en clair il
// n'aurait rien a reveler - et l'inverse : il le CACHERAIT. // n'aurait rien a reveler - et l'inverse : il le CACHERAIT.
// //
@@ -1333,6 +1393,25 @@ function newField(id, label, rowId) {
/// sanitisation de HTML et retire les retours a la ligne : on pouvait lire et /// sanitisation de HTML et retire les retours a la ligne : on pouvait lire et
/// modifier du multiligne, mais pas en creer - il fallait creer la note puis /// modifier du multiligne, mais pas en creer - il fallait creer la note puis
/// l'ouvrir pour la mettre en forme. /// l'ouvrir pour la mettre en forme.
/// MOT DE PASSE ALEATOIRE, tire de crypto.getRandomValues. Rejet des octets
/// au-dela du dernier multiple de la taille du jeu : un simple modulo
/// favoriserait les premiers caracteres.
var GEN_CHARS = 'ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz23456789'
+ '!@#$%^&*-_=+?';
function genPassword(n) {
var out = '', buf = new Uint8Array(1),
lim = 256 - (256 % GEN_CHARS.length);
while (out.length < (n || 20)) {
crypto.getRandomValues(buf);
if (buf[0] < lim) out += GEN_CHARS.charAt(buf[0] % GEN_CHARS.length);
}
return out;
}
function genButton(target) {
return '<button class="btn ico-btn" data-gen="' + target + '">'
+ ico('dice', 'Generate') + '</button>';
}
function newBodyControl(kind) { function newBodyControl(kind) {
if (kind === 'note') if (kind === 'note')
return '<textarea class="field-in" id="nPwd" rows="6" enterkeyhint="enter"' return '<textarea class="field-in" id="nPwd" rows="6" enterkeyhint="enter"'
@@ -1340,7 +1419,7 @@ function newBodyControl(kind) {
+ ';height:auto;padding:10px 14px;resize:vertical"></textarea>'; + ';height:auto;padding:10px 14px;resize:vertical"></textarea>';
return '<input class="field-in" id="nPwd" type="text" autocomplete="off"' return '<input class="field-in" id="nPwd" type="text" autocomplete="off"'
+ ' autocorrect="off" autocapitalize="none" spellcheck="false"' + ' autocorrect="off" autocapitalize="none" spellcheck="false"'
+ ' style="' + FIELD_STYLE + '">'; + ' style="' + FIELD_STYLE + '">' + genButton('nPwd');
} }
function openNewEntry() { function openNewEntry() {
@@ -1606,23 +1685,115 @@ document.addEventListener('click', function (ev) {
// LES REGLAGES. Ils lisent et ecrivent les MEMES champs que l'accueil - la // LES REGLAGES. Ils lisent et ecrivent les MEMES champs que l'accueil - la
// page n'en garde qu'une copie, Delphi reste la seule source. // page n'en garde qu'une copie, Delphi reste la seule source.
function openSettings() { function openSettings() {
document.getElementById('sUrl').value = elUrl.value; document.getElementById('sUrl').value = shortRepoUrl(elUrl.value);
document.getElementById('sTok').value = elTok.value; document.getElementById('sTok').value = elTok.value;
document.getElementById('sPwd').value = elPwd.value; document.getElementById('sPwd').value = elPwd.value;
document.getElementById('sPinNew').value = ''; document.getElementById('sPinNew').value = '';
document.getElementById('secCode').hidden = !vaultOpen; document.getElementById('secCode').hidden = !vaultOpen;
document.getElementById('sRepoErr').hidden = true;
// UN COFFRE EXISTE MAIS EST FERME : le mot de passe de synchro ne se change
// pas d'ici. Il ne vit que dans le coffre scelle, et seul un coffre ouvert
// permet de le verifier puis de l'y ranger - tape coffre ferme, il etait
// perdu a la fermeture de l'app.
var sp = document.getElementById('sPwd'),
locked = (authMode === 'open' || authMode === 'login') && !vaultOpen;
sp.disabled = locked;
sp.placeholder = locked ? 'saved in the vault - open it to see or change it'
: 'sync password';
cfgBase = cfgNow();
syncSaveBtn(false);
// La section n'existe que coffre ouvert : le dire tant qu'elle manque, et se
// taire quand elle est juste en dessous.
document.getElementById('sUnlockHint').textContent =
vaultOpen ? ' below' : ', which appears in these settings once the vault is open';
showLog(false); showLog(false);
document.body.classList.add('on-settings'); document.body.classList.add('on-settings');
autoGrow(document.getElementById('sUrl')); // mesurable seulement une fois affiche
send('state?view=settings'); send('state?view=settings');
} }
function closeSettings() { // ENREGISTRER EST UN GESTE, FERMER N'ENREGISTRE RIEN. Fermer enregistrait :
// Ce qui a ete tape ici redescend vers Delphi avant de fermer, sinon un // une URL effacee par erreur partait avec le retour, sans moyen de revenir.
// reglage modifie puis referme sans quitter le champ serait perdu. // Desormais retour = annuler, et la page repart des valeurs enregistrees.
elUrl.value = document.getElementById('sUrl').value.trim(); // SAVE NE S'ALLUME QUE SI QUELQUE CHOSE A CHANGE, compare aux valeurs
// enregistrees et non a la derniere frappe : taper un caractere puis l'effacer
// le rend de nouveau inactif. Apres un Save : coche, inactif, nouvelle base.
var cfgBase = '';
function cfgNow() {
return JSON.stringify([document.getElementById('sUrl').value.trim(),
document.getElementById('sTok').value.trim(),
document.getElementById('sPwd').value]);
}
function syncSaveBtn(justSaved) {
var b = document.getElementById('sSave'), dirty = cfgNow() !== cfgBase;
b.disabled = !dirty;
b.classList.toggle('main', dirty);
b.textContent = (!dirty && justSaved) ? String.fromCharCode(0x2713) + ' Saved' : 'Save';
}
['sUrl', 'sTok', 'sPwd'].forEach(function (id) {
document.getElementById(id).addEventListener('input', function () { syncSaveBtn(false); });
});
// L'ADRESSE DU DEPOT TELLE QUE LE NAVIGATEUR L'AFFICHE suffit :
// https://git.example.com/OWNER/REPO (ou .../src/branch/main/FICHIER) devient
// l'URL de l'API des contenus. Une URL d'API ou d'endpoint PHP passe telle quelle,
// et une forme non reconnue aussi - Sync dira alors ce qui ne va pas.
// LA ZONE DE L'URL PREND LA HAUTEUR DE SON TEXTE : une ligne pour une adresse
// courte, davantage si elle passe a la ligne.
function autoGrow(el) {
el.style.height = 'auto';
el.style.height = el.scrollHeight + 'px';
}
document.addEventListener('input', function (ev) {
if (ev.target.classList && ev.target.classList.contains('multi')) autoGrow(ev.target);
});
// L'inverse, pour l'affichage : l'URL d'API se relit comme l'adresse du depot.
function shortRepoUrl(u) {
var g = /^https:\/\/api\.github\.com\/repos\/([^\/]+)\/([^\/]+)\/contents\/(.+)$/i.exec(u || '');
if (g) return 'https://github.com/' + g[1] + '/' + g[2] +
(g[3] === 'vault-sync.json' ? '' : '/blob/main/' + g[3]);
var m = /^(https?:\/\/[^\/]+)\/api\/v1\/repos\/([^\/]+)\/([^\/]+)\/contents\/(.+)$/i.exec(u || '');
if (!m) return u;
return m[1] + '/' + m[2] + '/' + m[3] +
(m[4] === 'vault-sync.json' ? '' : '/src/branch/main/' + m[4]);
}
function normalizeRepoUrl(u) {
u = u.replace(/\s+/g, '');
if (!u || /\/api\/v1\/repos\//i.test(u) || /api\.github\.com\/repos\//i.test(u) ||
/\.php(\?|$)/i.test(u)) return u;
// GITHUB : l'adresse du depot est sur github.com, l'API sur api.github.com.
var g = u.match(/^https?:\/\/(www\.)?github\.com\/([^\/]+)\/([^\/]+?)(?:\.git)?(?:\/blob\/[^\/]+\/(.+?))?\/?$/i);
if (g) return 'https://api.github.com/repos/' + g[2] + '/' + g[3] +
'/contents/' + (g[4] || 'vault-sync.json');
var m = u.match(/^(https?:\/\/[^\/]+)\/([^\/]+)\/([^\/]+?)(?:\.git)?(?:\/src\/branch\/[^\/]+\/(.+?))?\/?$/i);
if (!m) return u;
return m[1] + '/api/v1/repos/' + m[2] + '/' + m[3] + '/contents/' + (m[4] || 'vault-sync.json');
}
// Pas de Save pour ces deux-la : une case se voit cochee, elle s'applique.
['sBack', 'sKbd'].forEach(function (id) {
document.getElementById(id).addEventListener('change', function () {
send('uipref?back=' + (document.getElementById('sBack').checked ? '1' : '0')
+ '&kbd=' + (document.getElementById('sKbd').checked ? '1' : '0'));
});
});
document.getElementById('sScan').addEventListener('click', function () {
send('scanqr');
});
document.getElementById('sSave').addEventListener('click', function () {
var sUrl = document.getElementById('sUrl');
elUrl.value = normalizeRepoUrl(sUrl.value);
sUrl.value = shortRepoUrl(elUrl.value);
autoGrow(sUrl);
elTok.value = document.getElementById('sTok').value.trim(); elTok.value = document.getElementById('sTok').value.trim();
elPwd.value = document.getElementById('sPwd').value; elPwd.value = document.getElementById('sPwd').value;
pushConfig(); pushConfig();
document.getElementById('sRepoErr').hidden = true;
cfgBase = cfgNow();
syncSaveBtn(true);
});
function closeSettings() {
document.body.classList.remove('on-settings'); document.body.classList.remove('on-settings');
send('state?view=' + view); send('state?view=' + view);
} }
@@ -1648,14 +1819,56 @@ document.getElementById('histBody').addEventListener('click', function (ev) {
document.getElementById('sLog').addEventListener('click', function () { document.getElementById('sLog').addEventListener('click', function () {
showLog(document.getElementById('log').hidden); showLog(document.getElementById('log').hidden);
}); });
document.getElementById('sPinSet').addEventListener('click', function () { // FACON D'OUVRIR. Delphi dit laquelle est en place (PM.setUnlockMode) ; chaque
var v = document.getElementById('sPinNew').value; // bouton envoie la commande qui existe deja pour la poser. Revenir au
if (!v) { toast('Type a code first'); return; } // verrouillage d'ecran, c'est retirer le code : il faut donc le code courant.
// DEMANDE EXPLICITE, EFFET IMMEDIAT. Le code ne se depose plus dans un champ var unlockMode = 'none', canDeviceLock = false, hasContainer = false;
// que l'ouverture suivante appliquerait : Delphi refuse si le coffre n'est function syncUnlockUi() {
// pas ouvert, ce qui prouve que le code courant est connu. var pw = hasContainer ? 'vault password' : 'sync password';
document.getElementById('sModePwd').dataset.label =
pw.charAt(0).toUpperCase() + pw.slice(1) + ' (type it above)';
['device', 'code', 'password'].forEach(function (m) {
var id = { device: 'sModeDevice', code: 'sModeCode', password: 'sModePwd' }[m];
var b = document.getElementById(id), on = unlockMode === m;
if (!b.dataset.label) b.dataset.label = b.textContent;
b.textContent = (on ? String.fromCharCode(0x2713) + ' ' : '') + b.dataset.label;
b.classList.toggle('main', on);
});
document.getElementById('sModeDevice').style.opacity = canDeviceLock ? 1 : .4;
document.getElementById('sModeNote').textContent =
{ device: 'Now: screen lock. Changing the screen lock or adding a fingerprint never deletes the vault.',
code: 'Now: app code. To go back to the screen lock, type the current code above.',
password: 'Now: ' + pw + '. To go back to the screen lock, type it above.',
none: 'Now: no protection - anyone holding the phone unlocked can open the vault.' }[unlockMode]
+ (canDeviceLock ? '' : ' This phone has no screen lock.');
document.getElementById('btnUsePwd').hidden =
!(authMode === 'open' && unlockMode === 'device' && hasContainer);
}
function modeField() {
var el = document.getElementById('sPinNew'), v = el.value;
el.value = '';
return v;
}
document.getElementById('sModeCode').addEventListener('click', function () {
var v = modeField();
if (!v) { toast('Type the new code above first'); return; }
send('pinset?c=' + encodeURIComponent(v)); send('pinset?c=' + encodeURIComponent(v));
document.getElementById('sPinNew').value = ''; });
document.getElementById('sModePwd').addEventListener('click', function () {
var v = modeField();
if (!v) { toast('Type the ' + (hasContainer ? 'vault' : 'sync') + ' password above first'); return; }
send('pinset?pw=1&c=' + encodeURIComponent(v));
});
document.getElementById('sModeDevice').addEventListener('click', function () {
if (!canDeviceLock) { toast('No screen lock on this phone - set one in Android settings first'); return; }
if (unlockMode === 'device') { toast('Already using the screen lock'); return; }
var v = modeField();
if (!v && unlockMode !== 'none') { toast('Type the current code or password above first'); return; }
send('pinclear?c=' + encodeURIComponent(v));
});
document.getElementById('btnUsePwd').addEventListener('click', function () {
PM.setAuthMode('login');
document.getElementById('pass').focus();
}); });
document.getElementById('sWipe').addEventListener('click', function (ev) { document.getElementById('sWipe').addEventListener('click', function (ev) {
// DEUX APPUIS, comme pour retirer le code : un effacement sans retour ne se // DEUX APPUIS, comme pour retirer le code : un effacement sans retour ne se
@@ -1675,27 +1888,6 @@ document.getElementById('sWipe').addEventListener('click', function (ev) {
send('wipelocal'); send('wipelocal');
closeSettings(); closeSettings();
}); });
document.getElementById('sPinClear').addEventListener('click', function (ev) {
var b = ev.currentTarget;
if (b.getAttribute('data-armed') === null) {
b.setAttribute('data-armed', '1');
b.textContent = 'Really remove - tap again';
setTimeout(function () {
b.removeAttribute('data-armed');
b.textContent = 'Remove the unlock code';
}, 4000);
return;
}
b.removeAttribute('data-armed');
b.textContent = 'Remove the unlock code';
// LE CODE COURANT VOYAGE AVEC LA DEMANDE. Le coffre ouvert ne prouve rien :
// il peut l'etre depuis une heure et rester a l'ecran. Delphi compare a ce
// sous quoi le cache est reellement scelle, et refuse sinon.
send('pinclear?c=' + encodeURIComponent(
document.getElementById('sPinNew').value));
document.getElementById('sPinNew').value = '';
});
function goList() { function goList() {
closeMenu(); closeMenu();
document.body.classList.remove('on-detail'); document.body.classList.remove('on-detail');
@@ -1710,6 +1902,21 @@ document.getElementById('back').addEventListener('click', goList);
// --- appele par Delphi ----------------------------------------------------- // --- appele par Delphi -----------------------------------------------------
var PM = { var PM = {
/// Reglages d'usage, relus au demarrage (Delphi en garde le fichier).
setUiPrefs: function (back, kbd) {
document.getElementById('sBack').checked = back;
document.getElementById('sKbd').checked = kbd;
},
/// Recherche prete a taper : focus, texte precedent selectionne (la frappe le
/// remplace), puis Delphi deplie le clavier - un focus() seul ne le fait pas.
focusSearch: function () {
if (view !== 'list') return;
q.focus();
q.select();
send('kbd');
},
setVault: function (json) { setVault: function (json) {
vaultOpen = true; vaultOpen = true;
var d = JSON.parse(json); var d = JSON.parse(json);
@@ -1751,6 +1958,13 @@ var PM = {
document.body.classList.remove('on-list', 'on-detail', 'searching'); document.body.classList.remove('on-list', 'on-detail', 'searching');
view = 'unlock'; view = 'unlock';
}, },
/// Erreur de depot, affichee dans les reglages au-dessus des champs a corriger.
settingsError: function (msg) {
var e = document.getElementById('sRepoErr');
e.textContent = msg;
e.hidden = false;
},
setStatus: function (text, err) { setStatus: function (text, err) {
var s = document.getElementById('status'); var s = document.getElementById('status');
s.textContent = text; s.textContent = text;
@@ -1774,6 +1988,17 @@ var PM = {
/// Ils ne s'affichent plus - le panneau repliable a cede la place au voile - /// Ils ne s'affichent plus - le panneau repliable a cede la place au voile -
/// mais c'est toujours d'eux que part pushConfig, et Delphi ne connait qu'eux. /// mais c'est toujours d'eux que part pushConfig, et Delphi ne connait qu'eux.
/// Les vider ferait perdre la configuration a la premiere synchronisation. /// Les vider ferait perdre la configuration a la premiere synchronisation.
/// Reglages lus dans le QR du poste : ils remplissent les champs, Save valide.
pasteConfig: function (url, tok) {
var u = document.getElementById('sUrl');
u.value = shortRepoUrl(url);
autoGrow(u);
document.getElementById('sTok').value = tok;
syncSaveBtn(false);
toast('URL and token pasted - type the sync password, then Save');
document.getElementById('sPwd').focus();
},
setConfig: function (url, tok, pwd, show) { setConfig: function (url, tok, pwd, show) {
// elPin volontairement absent : rien ne le restaure, jamais. // elPin volontairement absent : rien ne le restaure, jamais.
elUrl.value = url; elTok.value = tok; elPwd.value = pwd; elUrl.value = url; elTok.value = tok; elPwd.value = pwd;
@@ -1800,10 +2025,12 @@ var PM = {
// journal a demenage, et l'accueil n'en porte plus. Le geste qui le ramene // journal a demenage, et l'accueil n'en porte plus. Le geste qui le ramene
// ne change pas - un appui long sur la ligne d'etat. // ne change pas - un appui long sur la ligne d'etat.
document.getElementById('sLog').hidden = true; document.getElementById('sLog').hidden = true;
document.getElementById('sDiagH').hidden = true;
var st = document.getElementById('status'), timer = null; var st = document.getElementById('status'), timer = null;
st.addEventListener('touchstart', function () { st.addEventListener('touchstart', function () {
timer = setTimeout(function () { timer = setTimeout(function () {
document.getElementById('sLog').hidden = false; document.getElementById('sLog').hidden = false;
document.getElementById('sDiagH').hidden = false;
toast('Log available'); toast('Log available');
}, 1500); }, 1500);
}); });
@@ -1826,6 +2053,12 @@ var PM = {
syncPinbox(); syncPinbox();
document.getElementById('btnAuth').textContent = document.getElementById('btnAuth').textContent =
(mode === 'register') ? 'Create vault' : 'Sign in'; (mode === 'register') ? 'Create vault' : 'Sign in';
syncUnlockUi();
},
setUnlockMode: function (mode, canDevice, container) {
unlockMode = mode; canDeviceLock = canDevice; hasContainer = container;
syncUnlockUi();
}, },
setPinNeeded: function (on) { setPinNeeded: function (on) {
+5
View File
@@ -293,6 +293,11 @@ input[type="range"]::-webkit-slider-thumb {
color: var(--text); color: var(--text);
box-shadow: 0 1px 3px rgba(0,0,0,0.1); box-shadow: 0 1px 3px rgba(0,0,0,0.1);
} }
/* Invisibles MAIS presents tant que la 2e couche de licence n'a pas repondu
(applyRegisterVisibility) : visibles par defaut, ils laissaient voir Register
quelques millisecondes avant d'etre masques. visibility et non display : la
place reste reservee, donc rien ne saute quand ils apparaissent. */
.auth-tabs.is-pending { visibility: hidden; }
.auth-form { display: flex; flex-direction: column; } .auth-form { display: flex; flex-direction: column; }
.auth-form .btn-block { margin-top: 8px; } .auth-form .btn-block { margin-top: 8px; }
+2
View File
@@ -22,6 +22,8 @@ uses
PM.UserPrefs in 'Source\PM.UserPrefs.pas', PM.UserPrefs in 'Source\PM.UserPrefs.pas',
PM.MachineId in 'Source\PM.MachineId.pas', PM.MachineId in 'Source\PM.MachineId.pas',
PM.Licence in 'Source\PM.Licence.pas', PM.Licence in 'Source\PM.Licence.pas',
PM.LicenceGate in 'Source\PM.LicenceGate.pas',
DelphiZXingQRCode in 'Source\DelphiZXingQRCode.pas',
PM.AutoStart in 'Source\PM.AutoStart.pas', PM.AutoStart in 'Source\PM.AutoStart.pas',
PM.Favicon in 'Source\PM.Favicon.pas', PM.Favicon in 'Source\PM.Favicon.pas',
PM.ProcessLockdown in 'Source\PM.ProcessLockdown.pas', PM.ProcessLockdown in 'Source\PM.ProcessLockdown.pas',
+22 -1
View File
@@ -49,6 +49,12 @@
<Cfg_1>true</Cfg_1> <Cfg_1>true</Cfg_1>
<Base>true</Base> <Base>true</Base>
</PropertyGroup> </PropertyGroup>
<PropertyGroup Condition="('$(Platform)'=='Win64' and '$(Cfg_1)'=='true') or '$(Cfg_1_Win64)'!=''">
<Cfg_1_Win64>true</Cfg_1_Win64>
<CfgParent>Cfg_1</CfgParent>
<Cfg_1>true</Cfg_1>
<Base>true</Base>
</PropertyGroup>
<PropertyGroup Condition="'$(Config)'=='Debug' or '$(Cfg_2)'!=''"> <PropertyGroup Condition="'$(Config)'=='Debug' or '$(Cfg_2)'!=''">
<Cfg_2>true</Cfg_2> <Cfg_2>true</Cfg_2>
<CfgParent>Base</CfgParent> <CfgParent>Base</CfgParent>
@@ -157,6 +163,11 @@
<UWP_DelphiLogo150>$(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_150.png</UWP_DelphiLogo150> <UWP_DelphiLogo150>$(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_150.png</UWP_DelphiLogo150>
</PropertyGroup> </PropertyGroup>
<PropertyGroup Condition="'$(Base_Win64)'!=''"> <PropertyGroup Condition="'$(Base_Win64)'!=''">
<DCC_Namespace>Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)</DCC_Namespace>
<VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo>
<VerInfo_Keys>CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName)</VerInfo_Keys>
<VerInfo_Locale>1033</VerInfo_Locale>
<Manifest_File>$(BDS)\bin\default_app.manifest</Manifest_File>
<UWP_DelphiLogo44>$(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_44.png</UWP_DelphiLogo44> <UWP_DelphiLogo44>$(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_44.png</UWP_DelphiLogo44>
<UWP_DelphiLogo150>$(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_150.png</UWP_DelphiLogo150> <UWP_DelphiLogo150>$(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_150.png</UWP_DelphiLogo150>
</PropertyGroup> </PropertyGroup>
@@ -166,6 +177,14 @@
<DCC_LocalDebugSymbols>false</DCC_LocalDebugSymbols> <DCC_LocalDebugSymbols>false</DCC_LocalDebugSymbols>
<DCC_SymbolReferenceInfo>0</DCC_SymbolReferenceInfo> <DCC_SymbolReferenceInfo>0</DCC_SymbolReferenceInfo>
</PropertyGroup> </PropertyGroup>
<PropertyGroup Condition="'$(Cfg_1_Win64)'!=''">
<AppDPIAwarenessMode>PerMonitorV2</AppDPIAwarenessMode>
<VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo>
<VerInfo_Locale>1033</VerInfo_Locale>
<Icon_MainIcon>app.ico</Icon_MainIcon>
<UWP_DelphiLogo44>app.png</UWP_DelphiLogo44>
<UWP_DelphiLogo150>app.png</UWP_DelphiLogo150>
</PropertyGroup>
<PropertyGroup Condition="'$(Cfg_1_Win32)'!=''"> <PropertyGroup Condition="'$(Cfg_1_Win32)'!=''">
<AppDPIAwarenessMode>PerMonitorV2</AppDPIAwarenessMode> <AppDPIAwarenessMode>PerMonitorV2</AppDPIAwarenessMode>
<VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo>
@@ -229,6 +248,8 @@ $(PreBuildEvent)]]></PreBuildEvent>
<DCCReference Include="Source\PM.UserPrefs.pas"/> <DCCReference Include="Source\PM.UserPrefs.pas"/>
<DCCReference Include="Source\PM.MachineId.pas"/> <DCCReference Include="Source\PM.MachineId.pas"/>
<DCCReference Include="Source\PM.Licence.pas"/> <DCCReference Include="Source\PM.Licence.pas"/>
<DCCReference Include="Source\PM.LicenceGate.pas"/>
<DCCReference Include="Source\DelphiZXingQRCode.pas"/>
<DCCReference Include="Source\PM.AutoStart.pas"/> <DCCReference Include="Source\PM.AutoStart.pas"/>
<DCCReference Include="Source\PM.Favicon.pas"/> <DCCReference Include="Source\PM.Favicon.pas"/>
<DCCReference Include="Source\PM.ProcessLockdown.pas"/> <DCCReference Include="Source\PM.ProcessLockdown.pas"/>
@@ -274,7 +295,7 @@ $(PreBuildEvent)]]></PreBuildEvent>
<Platform value="OSX64">True</Platform> <Platform value="OSX64">True</Platform>
<Platform value="OSXARM64">True</Platform> <Platform value="OSXARM64">True</Platform>
<Platform value="Win32">True</Platform> <Platform value="Win32">True</Platform>
<Platform value="Win64">False</Platform> <Platform value="Win64">True</Platform>
</Platforms> </Platforms>
<Deployment Version="4"> <Deployment Version="4">
<DeployFile LocalName="$(BDS)\Redist\iossimulator\libcgunwind.1.0.dylib" Class="DependencyModule"> <DeployFile LocalName="$(BDS)\Redist\iossimulator\libcgunwind.1.0.dylib" Class="DependencyModule">
@@ -0,0 +1,202 @@
Apache License
Version 2.0, January 2004
http://www.apache.org/licenses/
TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION
1. Definitions.
"License" shall mean the terms and conditions for use, reproduction,
and distribution as defined by Sections 1 through 9 of this document.
"Licensor" shall mean the copyright owner or entity authorized by
the copyright owner that is granting the License.
"Legal Entity" shall mean the union of the acting entity and all
other entities that control, are controlled by, or are under common
control with that entity. For the purposes of this definition,
"control" means (i) the power, direct or indirect, to cause the
direction or management of such entity, whether by contract or
otherwise, or (ii) ownership of fifty percent (50%) or more of the
outstanding shares, or (iii) beneficial ownership of such entity.
"You" (or "Your") shall mean an individual or Legal Entity
exercising permissions granted by this License.
"Source" form shall mean the preferred form for making modifications,
including but not limited to software source code, documentation
source, and configuration files.
"Object" form shall mean any form resulting from mechanical
transformation or translation of a Source form, including but
not limited to compiled object code, generated documentation,
and conversions to other media types.
"Work" shall mean the work of authorship, whether in Source or
Object form, made available under the License, as indicated by a
copyright notice that is included in or attached to the work
(an example is provided in the Appendix below).
"Derivative Works" shall mean any work, whether in Source or Object
form, that is based on (or derived from) the Work and for which the
editorial revisions, annotations, elaborations, or other modifications
represent, as a whole, an original work of authorship. For the purposes
of this License, Derivative Works shall not include works that remain
separable from, or merely link (or bind by name) to the interfaces of,
the Work and Derivative Works thereof.
"Contribution" shall mean any work of authorship, including
the original version of the Work and any modifications or additions
to that Work or Derivative Works thereof, that is intentionally
submitted to Licensor for inclusion in the Work by the copyright owner
or by an individual or Legal Entity authorized to submit on behalf of
the copyright owner. For the purposes of this definition, "submitted"
means any form of electronic, verbal, or written communication sent
to the Licensor or its representatives, including but not limited to
communication on electronic mailing lists, source code control systems,
and issue tracking systems that are managed by, or on behalf of, the
Licensor for the purpose of discussing and improving the Work, but
excluding communication that is conspicuously marked or otherwise
designated in writing by the copyright owner as "Not a Contribution."
"Contributor" shall mean Licensor and any individual or Legal Entity
on behalf of whom a Contribution has been received by Licensor and
subsequently incorporated within the Work.
2. Grant of Copyright License. Subject to the terms and conditions of
this License, each Contributor hereby grants to You a perpetual,
worldwide, non-exclusive, no-charge, royalty-free, irrevocable
copyright license to reproduce, prepare Derivative Works of,
publicly display, publicly perform, sublicense, and distribute the
Work and such Derivative Works in Source or Object form.
3. Grant of Patent License. Subject to the terms and conditions of
this License, each Contributor hereby grants to You a perpetual,
worldwide, non-exclusive, no-charge, royalty-free, irrevocable
(except as stated in this section) patent license to make, have made,
use, offer to sell, sell, import, and otherwise transfer the Work,
where such license applies only to those patent claims licensable
by such Contributor that are necessarily infringed by their
Contribution(s) alone or by combination of their Contribution(s)
with the Work to which such Contribution(s) was submitted. If You
institute patent litigation against any entity (including a
cross-claim or counterclaim in a lawsuit) alleging that the Work
or a Contribution incorporated within the Work constitutes direct
or contributory patent infringement, then any patent licenses
granted to You under this License for that Work shall terminate
as of the date such litigation is filed.
4. Redistribution. You may reproduce and distribute copies of the
Work or Derivative Works thereof in any medium, with or without
modifications, and in Source or Object form, provided that You
meet the following conditions:
(a) You must give any other recipients of the Work or
Derivative Works a copy of this License; and
(b) You must cause any modified files to carry prominent notices
stating that You changed the files; and
(c) You must retain, in the Source form of any Derivative Works
that You distribute, all copyright, patent, trademark, and
attribution notices from the Source form of the Work,
excluding those notices that do not pertain to any part of
the Derivative Works; and
(d) If the Work includes a "NOTICE" text file as part of its
distribution, then any Derivative Works that You distribute must
include a readable copy of the attribution notices contained
within such NOTICE file, excluding those notices that do not
pertain to any part of the Derivative Works, in at least one
of the following places: within a NOTICE text file distributed
as part of the Derivative Works; within the Source form or
documentation, if provided along with the Derivative Works; or,
within a display generated by the Derivative Works, if and
wherever such third-party notices normally appear. The contents
of the NOTICE file are for informational purposes only and
do not modify the License. You may add Your own attribution
notices within Derivative Works that You distribute, alongside
or as an addendum to the NOTICE text from the Work, provided
that such additional attribution notices cannot be construed
as modifying the License.
You may add Your own copyright statement to Your modifications and
may provide additional or different license terms and conditions
for use, reproduction, or distribution of Your modifications, or
for any such Derivative Works as a whole, provided Your use,
reproduction, and distribution of the Work otherwise complies with
the conditions stated in this License.
5. Submission of Contributions. Unless You explicitly state otherwise,
any Contribution intentionally submitted for inclusion in the Work
by You to the Licensor shall be under the terms and conditions of
this License, without any additional terms or conditions.
Notwithstanding the above, nothing herein shall supersede or modify
the terms of any separate license agreement you may have executed
with Licensor regarding such Contributions.
6. Trademarks. This License does not grant permission to use the trade
names, trademarks, service marks, or product names of the Licensor,
except as required for reasonable and customary use in describing the
origin of the Work and reproducing the content of the NOTICE file.
7. Disclaimer of Warranty. Unless required by applicable law or
agreed to in writing, Licensor provides the Work (and each
Contributor provides its Contributions) on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or
implied, including, without limitation, any warranties or conditions
of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A
PARTICULAR PURPOSE. You are solely responsible for determining the
appropriateness of using or redistributing the Work and assume any
risks associated with Your exercise of permissions under this License.
8. Limitation of Liability. In no event and under no legal theory,
whether in tort (including negligence), contract, or otherwise,
unless required by applicable law (such as deliberate and grossly
negligent acts) or agreed to in writing, shall any Contributor be
liable to You for damages, including any direct, indirect, special,
incidental, or consequential damages of any character arising as a
result of this License or out of the use or inability to use the
Work (including but not limited to damages for loss of goodwill,
work stoppage, computer failure or malfunction, or any and all
other commercial damages or losses), even if such Contributor
has been advised of the possibility of such damages.
9. Accepting Warranty or Additional Liability. While redistributing
the Work or Derivative Works thereof, You may choose to offer,
and charge a fee for, acceptance of support, warranty, indemnity,
or other liability obligations and/or rights consistent with this
License. However, in accepting such obligations, You may act only
on Your own behalf and on Your sole responsibility, not on behalf
of any other Contributor, and only if You agree to indemnify,
defend, and hold each Contributor harmless for any liability
incurred by, or claims asserted against, such Contributor by reason
of your accepting any such warranty or additional liability.
END OF TERMS AND CONDITIONS
APPENDIX: How to apply the Apache License to your work.
To apply the Apache License to your work, attach the following
boilerplate notice, with the fields enclosed by brackets "{}"
replaced with your own identifying information. (Don't include
the brackets!) The text should be enclosed in the appropriate
comment syntax for the file format. We also recommend that a
file or class name and description of purpose be included on the
same "printed page" as the copyright notice for easier
identification within third-party archives.
Copyright {yyyy} {name of copyright owner}
Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
File diff suppressed because it is too large Load Diff
+249 -60
View File
@@ -116,6 +116,8 @@ type
// force-killed (which leaves -shm / -wal files behind). // force-killed (which leaves -shm / -wal files behind).
FShutdownPending: Boolean; FShutdownPending: Boolean;
FOnTrayRestore: TProc; FOnTrayRestore: TProc;
FOnFillBarSettings: TProc;
FOnFillBarChanged: TProc;
FOnLockRequest: TProc; FOnLockRequest: TProc;
FOnQuit: TProc; FOnQuit: TProc;
FOnQuickSearchRequest: TProc; FOnQuickSearchRequest: TProc;
@@ -169,7 +171,15 @@ type
// Dernier etat connu du survol, pour ne reposer l'opacite que sur un // Dernier etat connu du survol, pour ne reposer l'opacite que sur un
// changement - SetLayeredWindowAttributes force un repaint a chaque appel. // changement - SetLayeredWindowAttributes force un repaint a chaque appel.
FLazyHover: Boolean; FLazyHover: Boolean;
// Barrette en icones (police Segoe MDL2 Assets) plutot qu'en mots, et sa
// largeur reelle - elle depend des boutons choisis dans les reglages.
FLazyIcons: Boolean;
FLazyW: Integer;
procedure LazyWindowHandler(var AMsg: TMessage); procedure LazyWindowHandler(var AMsg: TMessage);
// Corps extraits des raccourcis Ctrl+Shift+A et Ctrl+Shift+Q : la barrette
// les declenche aussi, meme capture de la fenetre cible.
procedure FireNewEntryRequest;
procedure FireQuickSearchRequest;
/// Pose l'opacite qui convient a l'etat de survol donne. /// Pose l'opacite qui convient a l'etat de survol donne.
procedure ApplyLazyAlpha(AHover: Boolean); procedure ApplyLazyAlpha(AHover: Boolean);
/// Menu du clic droit sur la barrette : le choix de l'opacite au repos. /// Menu du clic droit sur la barrette : le choix de l'opacite au repos.
@@ -271,6 +281,10 @@ type
// peinture a besoin du theme. // peinture a besoin du theme.
procedure RestoreLazyBar; procedure RestoreLazyBar;
function LazyBarVisible: Boolean; function LazyBarVisible: Boolean;
/// Reconstruit la barrette apres un changement de ses reglages (boutons,
/// icones). POSTE : l'appel peut venir de la barrette elle-meme, qu'on ne
/// detruit pas depuis son propre gestionnaire.
procedure ReloadLazyBar;
property AutofillRegistered: Boolean read FAutofillRegistered; property AutofillRegistered: Boolean read FAutofillRegistered;
// Per-slot outcome of the last SetAutofillHotkeys — lets the host name // Per-slot outcome of the last SetAutofillHotkeys — lets the host name
// exactly which combo lost the race with another app's global hotkey // exactly which combo lost the race with another app's global hotkey
@@ -285,6 +299,12 @@ type
property ShutdownPending: Boolean read FShutdownPending; property ShutdownPending: Boolean read FShutdownPending;
// Fired on main thread when the user clicks the tray icon. // Fired on main thread when the user clicks the tray icon.
property OnTrayRestore: TProc read FOnTrayRestore write FOnTrayRestore; property OnTrayRestore: TProc read FOnTrayRestore write FOnTrayRestore;
// Clic droit sur la barrette -> "Fill bar settings..." : la fenetre revient
// (OnTrayRestore) puis l'hote ouvre l'onglet Fill bar des reglages.
property OnFillBarSettings: TProc read FOnFillBarSettings write FOnFillBarSettings;
// La barrette a change hors des reglages (clic droit, menu du tray) : l'hote
// rafraichit l'onglet Fill bar s'il est affiche.
property OnFillBarChanged: TProc read FOnFillBarChanged write FOnFillBarChanged;
// Fired when the user picks "Lock vault" from the tray menu. Handler // Fired when the user picks "Lock vault" from the tray menu. Handler
// should trigger the JS lockVault() (typically via ExecuteJavaScript). // should trigger the JS lockVault() (typically via ExecuteJavaScript).
property OnLockRequest: TProc read FOnLockRequest write FOnLockRequest; property OnLockRequest: TProc read FOnLockRequest write FOnLockRequest;
@@ -329,7 +349,7 @@ type
implementation implementation
uses uses
FMX.Platform.Win; FMX.Platform.Win, Winapi.CommCtrl;
// Foreground window at process start — captured in this unit's initialization, // Foreground window at process start — captured in this unit's initialization,
// which runs before any of our windows exist. Every later opportunity is // which runs before any of our windows exist. Every later opportunity is
@@ -377,6 +397,7 @@ const
// traitee sur place : detruire une fenetre depuis son propre gestionnaire // traitee sur place : detruire une fenetre depuis son propre gestionnaire
// libererait, en plein envoi, l'instance qui sert de window proc. // libererait, en plein envoi, l'instance qui sert de window proc.
WM_LAZY_CLOSE = WM_APP + 2; WM_LAZY_CLOSE = WM_APP + 2;
WM_LAZY_RELOAD = WM_APP + 3;
// WTS session change message and state constants (declared here to avoid // WTS session change message and state constants (declared here to avoid
// a hard dependency on Winapi.WtsApi32 which varies across Delphi versions). // a hard dependency on Winapi.WtsApi32 which varies across Delphi versions).
@@ -420,6 +441,11 @@ const
LAZY_ID_TOTP = 103; LAZY_ID_TOTP = 103;
LAZY_ID_CLOSE = 104; LAZY_ID_CLOSE = 104;
LAZY_ID_OPEN = 105; LAZY_ID_OPEN = 105;
LAZY_ID_ADD = 106; // nouvelle entree depuis la fenetre en avant (Ctrl+Shift+A)
LAZY_ID_SEARCH = 107; // recherche rapide (Ctrl+Shift+Q)
LAZY_ID_SETTINGS = 108; // reglages, onglet Fill bar
LAZY_MENU_ICONS = 1; // hors des valeurs d'opacite (25..100) du meme menu
LAZY_MENU_SETTINGS = 2;
// LE SONDAGE PLUTOT QUE TrackMouseEvent. La barrette a quatre fenetres // LE SONDAGE PLUTOT QUE TrackMouseEvent. La barrette a quatre fenetres
// enfants : passer d'elle a un bouton envoie deja un WM_MOUSELEAVE au parent, // enfants : passer d'elle a un bouton envoie deja un WM_MOUSELEAVE au parent,
// et il faudrait donc suivre la souris sur les cinq fenetres pour recoller // et il faudrait donc suivre la souris sur les cinq fenetres pour recoller
@@ -438,7 +464,11 @@ const
// elle doit revenir AVANT toute ouverture de coffre, et localStorage est vide // elle doit revenir AVANT toute ouverture de coffre, et localStorage est vide
// a chaque lancement (le port ephemere change d'origine). // a chaque lancement (le port ephemere change d'origine).
LAZY_ON_KEY = 'lazyOn'; LAZY_ON_KEY = 'lazyOn';
LAZY_W = 298; // Boutons affiches, dans l'ordre, et le choix icones/texte. Le X est toujours
// la : c'est la seule facon de fermer la barrette la ou elle est.
LAZY_BTNS_KEY = 'lazyButtons';
LAZY_BTNS_DEFAULT = 'full,pwd,totp,add,search,open,settings';
LAZY_ICONS_KEY = 'lazyIcons';
LAZY_H = 40; LAZY_H = 40;
// Palette de la barrette, en COLORREF ($00BBGGRR - les octets sont INVERSES // Palette de la barrette, en COLORREF ($00BBGGRR - les octets sont INVERSES
@@ -455,6 +485,9 @@ const
LAZY_LITE_DOWN = $DDE3E3; // --bg-elev-3 #e3e3dd LAZY_LITE_DOWN = $DDE3E3; // --bg-elev-3 #e3e3dd
LAZY_LITE_EDGE = $D7DCDC; // --border #dcdcd7 LAZY_LITE_EDGE = $D7DCDC; // --border #dcdcd7
LAZY_LITE_INK = $1F1A1A; // --text #1a1a1f LAZY_LITE_INK = $1F1A1A; // --text #1a1a1f
// Survol : l'accent de l'app, comme les boutons de la fenetre principale.
LAZY_DARK_ACCENT = $D4B606; // --accent #06b6d4
LAZY_LITE_ACCENT = $B29108; // --accent #0891b2
// Dynamic WTS function pointers — wtsapi32.dll is not guaranteed on all // Dynamic WTS function pointers — wtsapi32.dll is not guaranteed on all
// Windows SKUs (e.g. minimal Server Core without Session Services), so // Windows SKUs (e.g. minimal Server Core without Session Services), so
@@ -1101,6 +1134,8 @@ end;
// a retenir. // a retenir.
var var
GLazyOldBtnProc: Pointer = nil; GLazyOldBtnProc: Pointer = nil;
// Bouton de la barrette sous la souris (0 = aucun) : il se peint a l'accent.
GLazyHotBtn: HWND = 0;
/// Un appui sur un bouton de la barrette : clic, ou debut de glissement ? /// Un appui sur un bouton de la barrette : clic, ou debut de glissement ?
/// ///
@@ -1133,6 +1168,26 @@ begin
MAKEWPARAM(GetDlgCtrlID(AWnd), BN_CLICKED), LPARAM(AWnd)); MAKEWPARAM(GetDlgCtrlID(AWnd), BN_CLICKED), LPARAM(AWnd));
Exit(0); Exit(0);
end; end;
// LE SURVOL SE VOIT. Un bouton peint a la main n'a aucun etat "survole" :
// on le suit ici (entree par WM_MOUSEMOVE, sortie par WM_MOUSELEAVE demande a
// TrackMouseEvent) et on redessine les deux boutons concernes.
if (AMsg = WM_MOUSEMOVE) and (GLazyHotBtn <> AWnd) then
begin
if GLazyHotBtn <> 0 then InvalidateRect(GLazyHotBtn, nil, False);
GLazyHotBtn := AWnd;
InvalidateRect(AWnd, nil, False);
var LTrack: TTrackMouseEvent;
LTrack.cbSize := SizeOf(LTrack);
LTrack.dwFlags := TME_LEAVE;
LTrack.hwndTrack := AWnd;
LTrack.dwHoverTime := 0;
TrackMouseEvent(LTrack);
end
else if (AMsg = WM_MOUSELEAVE) and (GLazyHotBtn = AWnd) then
begin
GLazyHotBtn := 0;
InvalidateRect(AWnd, nil, False);
end;
Result := CallWindowProc(GLazyOldBtnProc, AWnd, AMsg, AWp, ALp); Result := CallWindowProc(GLazyOldBtnProc, AWnd, AMsg, AWp, ALp);
end; end;
@@ -1142,6 +1197,9 @@ var
LBrush: HBRUSH; LBrush: HBRUSH;
LFace, LEdge, LInk: COLORREF; LFace, LEdge, LInk: COLORREF;
LText: array[0..31] of Char; LText: array[0..31] of Char;
LGlyph: Char;
LFont: HFONT;
LOldFont: HGDIOBJ;
begin begin
LRect := ADraw.rcItem; LRect := ADraw.rcItem;
if FDarkTheme then if FDarkTheme then
@@ -1154,6 +1212,18 @@ begin
LFace := LAZY_LITE_FACE; LEdge := LAZY_LITE_EDGE; LInk := LAZY_LITE_INK; LFace := LAZY_LITE_FACE; LEdge := LAZY_LITE_EDGE; LInk := LAZY_LITE_INK;
if (ADraw.itemState and ODS_SELECTED) <> 0 then LFace := LAZY_LITE_DOWN; if (ADraw.itemState and ODS_SELECTED) <> 0 then LFace := LAZY_LITE_DOWN;
end; end;
// Survole : fond releve et encre a l'accent, cadre compris.
if ADraw.hwndItem = GLazyHotBtn then
begin
if FDarkTheme then
begin
LFace := LAZY_DARK_DOWN; LInk := LAZY_DARK_ACCENT; LEdge := LAZY_DARK_ACCENT;
end
else
begin
LFace := LAZY_LITE_DOWN; LInk := LAZY_LITE_ACCENT; LEdge := LAZY_LITE_ACCENT;
end;
end;
LBrush := CreateSolidBrush(LFace); LBrush := CreateSolidBrush(LFace);
FillRect(ADraw.hDC, LRect, LBrush); FillRect(ADraw.hDC, LRect, LBrush);
@@ -1162,11 +1232,36 @@ begin
FrameRect(ADraw.hDC, LRect, LBrush); FrameRect(ADraw.hDC, LRect, LBrush);
DeleteObject(LBrush); DeleteObject(LBrush);
SetBkMode(ADraw.hDC, TRANSPARENT);
SetTextColor(ADraw.hDC, LInk);
if FLazyIcons then
begin
// Segoe MDL2 Assets, livree avec Windows 10 et 11 : aucune image a
// embarquer, et le glyphe suit la couleur du texte comme un mot.
case ADraw.CtlID of
LAZY_ID_FULL: LGlyph := #$E77B; // Contact
LAZY_ID_PWD: LGlyph := #$E8D7; // Permissions (cle)
LAZY_ID_TOTP: LGlyph := #$E823; // Recent (horloge du code)
LAZY_ID_ADD: LGlyph := #$E710; // Add
LAZY_ID_SEARCH: LGlyph := #$E721; // Search
LAZY_ID_OPEN: LGlyph := #$E8A7; // OpenInNewWindow
LAZY_ID_SETTINGS: LGlyph := #$E713; // Settings (roue)
else
LGlyph := #$E711; // Cancel (X)
end;
LFont := CreateFont(-16, 0, 0, 0, FW_NORMAL, 0, 0, 0, DEFAULT_CHARSET,
OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, CLEARTYPE_QUALITY,
DEFAULT_PITCH, 'Segoe MDL2 Assets');
LOldFont := SelectObject(ADraw.hDC, LFont);
DrawText(ADraw.hDC, PChar(LGlyph), 1, LRect,
DT_CENTER or DT_VCENTER or DT_SINGLELINE);
SelectObject(ADraw.hDC, LOldFont);
DeleteObject(LFont);
Exit;
end;
// Le libelle est celui de la fenetre-bouton : une seule verite, posee a la // Le libelle est celui de la fenetre-bouton : une seule verite, posee a la
// creation, plutot qu'une table de correspondance a tenir a jour. // creation, plutot qu'une table de correspondance a tenir a jour.
GetWindowText(ADraw.hwndItem, LText, Length(LText)); GetWindowText(ADraw.hwndItem, LText, Length(LText));
SetBkMode(ADraw.hDC, TRANSPARENT);
SetTextColor(ADraw.hDC, LInk);
DrawText(ADraw.hDC, LText, -1, LRect, DrawText(ADraw.hDC, LText, -1, LRect,
DT_CENTER or DT_VCENTER or DT_SINGLELINE); DT_CENTER or DT_VCENTER or DT_SINGLELINE);
end; end;
@@ -1191,6 +1286,7 @@ var
LPt: TPoint; LPt: TPoint;
LCmd: Cardinal; LCmd: Cardinal;
I: Integer; I: Integer;
LIconsLabel: string;
begin begin
LMenu := CreatePopupMenu; LMenu := CreatePopupMenu;
if LMenu = 0 then Exit; if LMenu = 0 then Exit;
@@ -1199,6 +1295,10 @@ begin
AppendMenu(LMenu, AppendMenu(LMenu,
MF_STRING or IfThen(FLazyAlphaPct = CHOICES[I], MF_CHECKED, MF_UNCHECKED), MF_STRING or IfThen(FLazyAlphaPct = CHOICES[I], MF_CHECKED, MF_UNCHECKED),
CHOICES[I], PChar(Format('%d%% when the mouse leaves', [CHOICES[I]]))); CHOICES[I], PChar(Format('%d%% when the mouse leaves', [CHOICES[I]])));
if FLazyIcons then LIconsLabel := 'Show text' else LIconsLabel := 'Show icons';
AppendMenu(LMenu, MF_SEPARATOR, 0, nil);
AppendMenu(LMenu, MF_STRING, LAZY_MENU_ICONS, PChar(LIconsLabel));
AppendMenu(LMenu, MF_STRING, LAZY_MENU_SETTINGS, 'Fill bar settings...');
// LE BATTEMENT DOIT S'ARRETER PENDANT LE MENU. Il repose la barrette en // LE BATTEMENT DOIT S'ARRETER PENDANT LE MENU. Il repose la barrette en
// tete de la bande TOPMOST cinq fois par seconde - or le menu deroulant est // tete de la bande TOPMOST cinq fois par seconde - or le menu deroulant est
@@ -1216,11 +1316,22 @@ begin
LPt.X, LPt.Y, 0, FMsgWindow, nil)); LPt.X, LPt.Y, 0, FMsgWindow, nil));
PostMessage(FMsgWindow, WM_NULL, 0, 0); PostMessage(FMsgWindow, WM_NULL, 0, 0);
if LCmd > 0 then if LCmd = LAZY_MENU_SETTINGS then
begin
if Assigned(FOnTrayRestore) then FOnTrayRestore();
if Assigned(FOnFillBarSettings) then FOnFillBarSettings();
end
else if LCmd = LAZY_MENU_ICONS then
begin
if FLazyIcons then SetPref(LAZY_ICONS_KEY, '0') else SetPref(LAZY_ICONS_KEY, '1');
ReloadLazyBar;
end
else if LCmd > 0 then
begin begin
FLazyAlphaPct := LCmd; FLazyAlphaPct := LCmd;
SetPref(LAZY_ALPHA_KEY, IntToStr(FLazyAlphaPct)); SetPref(LAZY_ALPHA_KEY, IntToStr(FLazyAlphaPct));
ApplyLazyAlpha(FLazyHover); ApplyLazyAlpha(FLazyHover);
if Assigned(FOnFillBarChanged) then FOnFillBarChanged();
end; end;
finally finally
DestroyMenu(LMenu); DestroyMenu(LMenu);
@@ -1317,6 +1428,13 @@ begin
LAZY_ID_PWD: FireAutofillRequest(akPasswordOnly, True); LAZY_ID_PWD: FireAutofillRequest(akPasswordOnly, True);
LAZY_ID_TOTP: FireAutofillRequest(akTotp, True); LAZY_ID_TOTP: FireAutofillRequest(akTotp, True);
LAZY_ID_OPEN: if Assigned(FOnTrayRestore) then FOnTrayRestore(); LAZY_ID_OPEN: if Assigned(FOnTrayRestore) then FOnTrayRestore();
LAZY_ID_ADD: FireNewEntryRequest;
LAZY_ID_SEARCH: FireQuickSearchRequest;
LAZY_ID_SETTINGS:
begin
if Assigned(FOnTrayRestore) then FOnTrayRestore();
if Assigned(FOnFillBarSettings) then FOnFillBarSettings();
end;
LAZY_ID_CLOSE: PostMessage(FMsgWindow, WM_LAZY_CLOSE, 0, 0); LAZY_ID_CLOSE: PostMessage(FMsgWindow, WM_LAZY_CLOSE, 0, 0);
end; end;
AMsg.Result := 0; AMsg.Result := 0;
@@ -1326,20 +1444,84 @@ begin
AMsg.Result := DefWindowProc(FLazyWnd, AMsg.Msg, AMsg.WParam, AMsg.LParam); AMsg.Result := DefWindowProc(FLazyWnd, AMsg.Msg, AMsg.WParam, AMsg.LParam);
end; end;
procedure TPMBridge.FireNewEntryRequest;
var
LTarget: HWND;
LTitle: string;
LLen: Integer;
begin
if not Assigned(FOnNewEntryHotkey) then Exit;
LTarget := GetForegroundWindow;
LTitle := '';
// The window we are about to cover is exactly the one to hand the
// foreground back to when we return to the tray.
CaptureForegroundOwner;
// From the tray the foreground can resolve to OUR own window — don't
// pre-fill the new entry with "Password Manager". Only capture a real
// external window's title; otherwise pass '' (blank title).
if not IsOwnProcessWindow(LTarget) then
begin
SetLength(LTitle, 512);
LLen := GetWindowTextW(LTarget, PChar(LTitle), 512);
SetLength(LTitle, LLen);
end;
FOnNewEntryHotkey(LTitle);
end;
procedure TPMBridge.FireQuickSearchRequest;
var
LTarget: HWND;
LTitle: string;
LLen: Integer;
begin
// Quick-search + autofill: capture the foreground HWND BEFORE the JS
// modal steals focus, hand it to the host so it can stash it in
// FAutofillTargetHWND (consumed by cmd://autofill/execute later).
if not Assigned(FOnQuickSearchHotkey) then Exit;
LTarget := GetForegroundWindow;
CaptureForegroundOwner;
// Same trap as the autofill hotkeys: our own hidden window can be the
// foreground one. Report no target — the host then opens quick search in
// copy mode instead of offering to type into ourselves.
if IsOwnProcessWindow(LTarget) then LTarget := 0;
LTitle := '';
if LTarget <> 0 then
begin
SetLength(LTitle, 512);
LLen := GetWindowTextW(LTarget, PChar(LTitle), 512);
SetLength(LTitle, LLen);
end;
FOnQuickSearchHotkey(akPasswordOnly, LTarget, LTitle);
end;
procedure TPMBridge.ReloadLazyBar;
begin
PostMessage(FMsgWindow, WM_LAZY_RELOAD, 0, 0);
end;
procedure TPMBridge.RestoreLazyBar; procedure TPMBridge.RestoreLazyBar;
begin begin
if GetPref(LAZY_ON_KEY) = '1' then SetLazyBar(True); if GetPref(LAZY_ON_KEY) = '1' then SetLazyBar(True);
end; end;
procedure TPMBridge.SetLazyBar(AOn: Boolean); procedure TPMBridge.SetLazyBar(AOn: Boolean);
// Declarees AVANT les routines imbriquees, qui s'en servent : une routine
// imbriquee ne voit que les variables declarees au-dessus d'elle.
var
LWork, LRect: TRect;
LSaved: TArray<string>;
LX, LY, LPosX, LPosY: Integer;
LList: string;
LTip: HWND;
// BS_OWNERDRAW : le systeme garde le suivi de la souris et l'etat enfonce, // BS_OWNERDRAW : le systeme garde le suivi de la souris et l'etat enfonce,
// nous ne reprenons que les couleurs. Un bouton standard resterait gris clair // nous ne reprenons que les couleurs. Un bouton standard resterait gris clair
// sur fond sombre, comme sur la capture qui a motive ce changement. // sur fond sombre, comme sur la capture qui a motive ce changement.
procedure MakeButton(AId: Integer; const ACaption: string; procedure MakeButton(AId: Integer; const ACaption, ATip: string;
AX, AWidth: Integer); AX, AWidth: Integer);
var var
LBtn: HWND; LBtn: HWND;
LTool: TToolInfo;
begin begin
LBtn := CreateWindow('BUTTON', PChar(ACaption), LBtn := CreateWindow('BUTTON', PChar(ACaption),
WS_CHILD or WS_VISIBLE or BS_OWNERDRAW, AX, 5, AWidth, 28, WS_CHILD or WS_VISIBLE or BS_OWNERDRAW, AX, 5, AWidth, 28,
@@ -1349,12 +1531,32 @@ procedure TPMBridge.SetLazyBar(AOn: Boolean);
SendMessage(LBtn, WM_SETFONT, WPARAM(GetStockObject(DEFAULT_GUI_FONT)), 1); SendMessage(LBtn, WM_SETFONT, WPARAM(GetStockObject(DEFAULT_GUI_FONT)), 1);
GLazyOldBtnProc := Pointer(SetWindowLongPtr(LBtn, GWLP_WNDPROC, GLazyOldBtnProc := Pointer(SetWindowLongPtr(LBtn, GWLP_WNDPROC,
LONG_PTR(@LazyButtonProc))); LONG_PTR(@LazyButtonProc)));
// UNE ICONE SANS MOT SE NOMME AU SURVOL. Info-bulle posee dans les deux
// modes : elle dit aussi ce que fait "Add" ou "Search" en texte.
if LTip <> 0 then
begin
FillChar(LTool, SizeOf(LTool), 0);
LTool.cbSize := SizeOf(LTool);
LTool.uFlags := TTF_IDISHWND or TTF_SUBCLASS;
LTool.hwnd := FLazyWnd;
LTool.uId := UINT_PTR(LBtn);
LTool.lpszText := PChar(ATip);
SendMessage(LTip, TTM_ADDTOOL, 0, LPARAM(@LTool));
end;
end;
// Un bouton du jeu choisi dans les reglages, pose a la suite des precedents.
procedure AddButton(const AKey: string; AId: Integer;
const ACaption, ATip: string; ATextWidth: Integer);
var
LW: Integer;
begin
if not (',' + LList + ',').Contains(',' + AKey + ',') then Exit;
LW := IfThen(FLazyIcons, 30, ATextWidth);
MakeButton(AId, ACaption, ATip, LX, LW);
Inc(LX, LW + 6);
end; end;
var
LWork, LRect: TRect;
LSaved: TArray<string>;
LX, LY, LPosX, LPosY: Integer;
begin begin
if AOn = LazyBarVisible then Exit; if AOn = LazyBarVisible then Exit;
if AOn then SetPref(LAZY_ON_KEY, '1') else SetPref(LAZY_ON_KEY, '0'); if AOn then SetPref(LAZY_ON_KEY, '1') else SetPref(LAZY_ON_KEY, '0');
@@ -1363,6 +1565,7 @@ begin
begin begin
DeallocateHWnd(FLazyWnd); // the child buttons go with their parent DeallocateHWnd(FLazyWnd); // the child buttons go with their parent
FLazyWnd := 0; FLazyWnd := 0;
if Assigned(FOnFillBarChanged) then FOnFillBarChanged();
Exit; Exit;
end; end;
@@ -1376,23 +1579,38 @@ begin
if (FLazyAlphaPct < 25) or (FLazyAlphaPct > 100) then if (FLazyAlphaPct < 25) or (FLazyAlphaPct > 100) then
FLazyAlphaPct := LAZY_ALPHA_DEFAULT; FLazyAlphaPct := LAZY_ALPHA_DEFAULT;
MakeButton(LAZY_ID_FULL, 'Full', 5, 56); FLazyIcons := GetPref(LAZY_ICONS_KEY) = '1';
MakeButton(LAZY_ID_PWD, 'Password', 67, 76); LList := GetPref(LAZY_BTNS_KEY);
MakeButton(LAZY_ID_TOTP, '2FA', 149, 52); if LList = '' then LList := LAZY_BTNS_DEFAULT;
InitCommonControls;
LTip := CreateWindowEx(WS_EX_TOPMOST, TOOLTIPS_CLASS, nil,
WS_POPUP or TTS_ALWAYSTIP or TTS_NOPREFIX,
Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT),
Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT),
FLazyWnd, 0, HInstance, nil);
LX := 5;
AddButton('full', LAZY_ID_FULL, 'Full', 'Fill username and password', 56);
AddButton('pwd', LAZY_ID_PWD, 'Password', 'Fill the password only', 76);
AddButton('totp', LAZY_ID_TOTP, '2FA', 'Fill the 2FA code', 52);
AddButton('add', LAZY_ID_ADD, 'Add', 'New entry from the current window', 48);
AddButton('search', LAZY_ID_SEARCH, 'Search', 'Quick search', 60);
// Meme raison que le X : quand la barrette est allumee, elle est souvent la // Meme raison que le X : quand la barrette est allumee, elle est souvent la
// seule chose de l'application a l'ecran. Revenir au coffre ne doit pas // seule chose de l'application a l'ecran. Revenir au coffre ne doit pas
// demander de retrouver l'icone du tray. // demander de retrouver l'icone du tray.
MakeButton(LAZY_ID_OPEN, 'Open', 207, 56); AddButton('open', LAZY_ID_OPEN, 'Open', 'Open the vault', 56);
AddButton('settings', LAZY_ID_SETTINGS, 'Settings', 'Fill bar settings', 64);
// Fermer la barrette sans passer par le menu du tray : elle flotte au-dessus // Fermer la barrette sans passer par le menu du tray : elle flotte au-dessus
// de tout, donc s'en debarrasser doit se faire la ou elle est. // de tout, donc s'en debarrasser doit se faire la ou elle est.
MakeButton(LAZY_ID_CLOSE, 'X', 269, 24); MakeButton(LAZY_ID_CLOSE, 'X', 'Close the fill bar', LX, 24);
FLazyW := LX + 24 + 5;
// Bottom right of the WORK area, so it does not start life under the // Bottom right of the WORK area, so it does not start life under the
// taskbar. From there the user drags it wherever the login form is. // taskbar. From there the user drags it wherever the login form is.
if not SystemParametersInfo(SPI_GETWORKAREA, 0, @LWork, 0) then if not SystemParametersInfo(SPI_GETWORKAREA, 0, @LWork, 0) then
LWork := Rect(0, 0, GetSystemMetrics(SM_CXSCREEN), LWork := Rect(0, 0, GetSystemMetrics(SM_CXSCREEN),
GetSystemMetrics(SM_CYSCREEN)); GetSystemMetrics(SM_CYSCREEN));
LX := LWork.Right - LAZY_W - 24; LX := LWork.Right - FLazyW - 24;
LY := LWork.Bottom - LAZY_H - 24; LY := LWork.Bottom - LAZY_H - 24;
// LA POSITION RETENUE, SI ELLE TOMBE ENCORE SUR UN ECRAN. Un ecran debranche // LA POSITION RETENUE, SI ELLE TOMBE ENCORE SUR UN ECRAN. Un ecran debranche
@@ -1403,7 +1621,7 @@ begin
if (Length(LSaved) = 2) and TryStrToInt(LSaved[0], LPosX) if (Length(LSaved) = 2) and TryStrToInt(LSaved[0], LPosX)
and TryStrToInt(LSaved[1], LPosY) then and TryStrToInt(LSaved[1], LPosY) then
begin begin
LRect := Rect(LPosX, LPosY, LPosX + LAZY_W, LPosY + LAZY_H); LRect := Rect(LPosX, LPosY, LPosX + FLazyW, LPosY + LAZY_H);
if MonitorFromRect(@LRect, MONITOR_DEFAULTTONULL) <> 0 then if MonitorFromRect(@LRect, MONITOR_DEFAULTTONULL) <> 0 then
begin begin
LX := LPosX; LX := LPosX;
@@ -1411,7 +1629,7 @@ begin
end; end;
end; end;
SetWindowPos(FLazyWnd, HWND_TOPMOST, LX, LY, LAZY_W, LAZY_H, SetWindowPos(FLazyWnd, HWND_TOPMOST, LX, LY, FLazyW, LAZY_H,
SWP_NOACTIVATE or SWP_SHOWWINDOW); SWP_NOACTIVATE or SWP_SHOWWINDOW);
// La souris est ailleurs a la seconde ou la barrette parait : elle nait donc // La souris est ailleurs a la seconde ou la barrette parait : elle nait donc
@@ -1419,6 +1637,7 @@ begin
FLazyHover := False; FLazyHover := False;
ApplyLazyAlpha(False); ApplyLazyAlpha(False);
SetTimer(FLazyWnd, LAZY_TIMER_ID, LAZY_POLL_MS, nil); SetTimer(FLazyWnd, LAZY_TIMER_ID, LAZY_POLL_MS, nil);
if Assigned(FOnFillBarChanged) then FOnFillBarChanged();
end; end;
procedure TPMBridge.MsgWindowHandler(var AMsg: TMessage); procedure TPMBridge.MsgWindowHandler(var AMsg: TMessage);
@@ -1435,6 +1654,16 @@ begin
Exit; Exit;
end end
else if AMsg.Msg = WM_LAZY_RELOAD then
begin
if LazyBarVisible then
begin
SetLazyBar(False);
SetLazyBar(True);
end;
Exit;
end
else if AMsg.Msg = WM_TRAY_ICON then else if AMsg.Msg = WM_TRAY_ICON then
begin begin
// For Shell_NotifyIcon callback messages, the mouse event is in the // For Shell_NotifyIcon callback messages, the mouse event is in the
@@ -1495,50 +1724,10 @@ begin
end end
else if (AMsg.Msg = WM_HOTKEY) and (AMsg.WParam = NEW_ENTRY_HOTKEY_ID) then else if (AMsg.Msg = WM_HOTKEY) and (AMsg.WParam = NEW_ENTRY_HOTKEY_ID) then
begin FireNewEntryRequest
if Assigned(FOnNewEntryHotkey) then
begin
var LTarget := GetForegroundWindow;
var LTitle: string := '';
// The window we are about to cover is exactly the one to hand the
// foreground back to when we return to the tray.
CaptureForegroundOwner;
// From the tray the foreground can resolve to OUR own window — don't
// pre-fill the new entry with "Password Manager". Only capture a real
// external window's title; otherwise pass '' (blank title).
if not IsOwnProcessWindow(LTarget) then
begin
SetLength(LTitle, 512);
var LLen := GetWindowTextW(LTarget, PChar(LTitle), 512);
SetLength(LTitle, LLen);
end;
FOnNewEntryHotkey(LTitle);
end;
end
else if (AMsg.Msg = WM_HOTKEY) and (AMsg.WParam = QUICK_SEARCH_HOTKEY_ID) then else if (AMsg.Msg = WM_HOTKEY) and (AMsg.WParam = QUICK_SEARCH_HOTKEY_ID) then
begin FireQuickSearchRequest
// Quick-search + autofill: capture the foreground HWND BEFORE the JS
// modal steals focus, hand it to the host so it can stash it in
// FAutofillTargetHWND (consumed by cmd://autofill/execute later).
if Assigned(FOnQuickSearchHotkey) then
begin
var LTarget := GetForegroundWindow;
CaptureForegroundOwner;
// Same trap as the autofill hotkeys: our own hidden window can be the
// foreground one. Report no target — the host then opens quick search in
// copy mode instead of offering to type into ourselves.
if IsOwnProcessWindow(LTarget) then LTarget := 0;
var LTitle: string;
if LTarget <> 0 then
begin
SetLength(LTitle, 512);
var LLen := GetWindowTextW(LTarget, PChar(LTitle), 512);
SetLength(LTitle, LLen);
end;
FOnQuickSearchHotkey(akPasswordOnly, LTarget, LTitle);
end;
end
else if (AMsg.Msg = WM_HOTKEY) and Assigned(FOnAutofillRequest) and else if (AMsg.Msg = WM_HOTKEY) and Assigned(FOnAutofillRequest) and
((AMsg.WParam = AUTOFILL_HOTKEY_ID_FULL) or ((AMsg.WParam = AUTOFILL_HOTKEY_ID_FULL) or
+6
View File
@@ -14,6 +14,12 @@ uses
System.SysUtils, System.Classes, System.IOUtils, System.SyncObjs, System.SysUtils, System.Classes, System.IOUtils, System.SyncObjs,
FireDAC.Comp.Client, FireDAC.Stan.Def, FireDAC.Stan.Async, FireDAC.Comp.Client, FireDAC.Stan.Def, FireDAC.Stan.Async,
FireDAC.Phys.SQLite, FireDAC.DApt, FireDAC.Stan.Param, FireDAC.Phys.SQLite, FireDAC.DApt, FireDAC.Stan.Param,
// SQLITE LIE DANS L'EXE, SUR TOUTES LES PLATEFORMES. En Win32 FireDAC le
// faisait deja par defaut ; en Win64 il cherchait sqlite3.dll a cote de
// l'exe et refusait de demarrer. On ne livre qu'un exe, sans DLL : cette
// unite est ce qui le permet en 64 bits. Stat et non FDEStat — le coffre
// est un SQLite ordinaire, le chiffrement se fait cote JavaScript.
FireDAC.Phys.SQLiteWrapper.Stat,
FireDAC.FMXUI.Wait, FireDAC.Stan.Intf, FireDAC.UI.Intf, FireDAC.FMXUI.Wait, FireDAC.Stan.Intf, FireDAC.UI.Intf,
Data.DB; Data.DB;
+12 -2
View File
@@ -60,6 +60,13 @@ function ThisMachineId: string;
// l'initialisation de l'unite, comme SelfTestCrypto. // l'initialisation de l'unite, comme SelfTestCrypto.
procedure SelfTestLicence; procedure SelfTestLicence;
// Exposes pour PM.LicenceGate, la deuxieme couche. Ce sont des DONNEES, pas
// des decisions : elle partage la cle et le nom de la pref, et rien qui dise
// oui ou non — sinon rapiecer une seule fonction ouvrirait les deux couches.
const
LicencePrefKey = 'licenceKey';
function LicencePublicKey: TBytes;
implementation implementation
uses uses
@@ -67,8 +74,6 @@ uses
PM.UserPrefs, PM.MachineId; PM.UserPrefs, PM.MachineId;
const const
LicencePrefKey = 'licenceKey';
// ===== LA CLE PUBLIQUE DE L'EDITEUR ======================================== // ===== LA CLE PUBLIQUE DE L'EDITEUR ========================================
// //
// BCRYPT_ECCPUBLIC_BLOB : magic 'ECS1' + longueur(32) + X(32) + Y(32). // BCRYPT_ECCPUBLIC_BLOB : magic 'ECS1' + longueur(32) + X(32) + Y(32).
@@ -258,6 +263,11 @@ begin
Move(LicencePublicKeyBlob[0], Result[0], EccBlobLen); Move(LicencePublicKeyBlob[0], Result[0], EccBlobLen);
end; end;
function LicencePublicKey: TBytes;
begin
Result := ProductionKey;
end;
function VerifyLicence(const ALicence: string; out AInfo: TLicenceInfo): Boolean; function VerifyLicence(const ALicence: string; out AInfo: TLicenceInfo): Boolean;
begin begin
Result := SplitAndVerify(ProductionKey, Trim(ALicence), AInfo) and Result := SplitAndVerify(ProductionKey, Trim(ALicence), AInfo) and
+220
View File
@@ -0,0 +1,220 @@
unit PM.LicenceGate;
{
Deuxieme couche de licence : l'API refuse de servir sans licence valable.
POURQUOI UNE DEUXIEME COUCHE, ET POURQUOI ICI. La premiere couche est l'ecran
d'activation, qui consulte PM.Licence.IsLicensed. C'est un seul branchement :
le rapiecer ouvrait tout, puisque l'API elle-meme ne demandait rien. Celle-ci
garde la porte LA OU SONT LES DONNEES — chaque route de PM.Router passe par
ApiLicenceOk avant son handler. Sauter l'ecran ne donne plus acces a rien.
AUCUNE FONCTION DE DECISION PARTAGEE AVEC PM.Licence. Si les deux couches
appelaient IsLicensed, rapiecer IsLicensed ouvrirait les deux d'un coup, et il
n'y aurait qu'une couche habillee en deux. Cette unite refait donc sa propre
verification de bout en bout — decodage, empreinte SHA-256, appel CNG, lecture
du champ machine — et ne prend a PM.Licence que des DONNEES : la cle publique
et le nom de la pref. Il faut trouver et rapiecer deux branchements distincts.
LE PRIX DE L'INDEPENDANCE : deux implementations qui doivent dire la meme
chose. Si elles divergeaient, un client licencie verrait l'ecran s'effacer
puis chaque requete tomber en 404 — le pire defaut possible, celui qui refuse
quelqu'un qui a paye. Deux garde-fous, et il faut savoir ce que chacun
couvre :
- SelfTestLicenceGate eprouve CETTE verification seule, sur un vecteur lie a
une empreinte fixe, et commence par le sens qui accepte — celui dont
l'echec coute le plus.
- L'ACCORD entre les deux couches ne se teste pas ici : la premiere compare a
l'empreinte reelle du poste, qui n'est pas un vecteur. Il se prouve en
lancant l'application avec une vraie licence — l'ecran passe (1re couche) ET
la connexion aboutit (2e couche).
CE QUE CA N'ARRETE PAS : quelqu'un qui trouve et rapiece les deux. Ca passe
d'une heure a deux ; ca ne change pas la nature d'un schema hors ligne.
}
interface
uses
System.SysUtils;
// L'API peut-elle servir ? Revenu vrai une fois, retenu pour le processus :
// une licence valable ne cesse pas de l'etre en cours de route, et ce test se
// trouve sur le chemin de CHAQUE requete. Un refus n'est jamais retenu — une
// activation faite juste apres doit etre vue a la requete suivante.
function ApiLicenceOk: Boolean;
procedure SelfTestLicenceGate;
implementation
uses
System.JSON, System.Hash, System.NetEncoding, Winapi.Windows,
PM.UserPrefs, PM.MachineId, PM.Licence;
// ===== CNG, redeclare ici expres ============================================
//
// Les memes fonctions que PM.Licence, declarees une seconde fois : les partager
// ferait de leur appelant commun un point de rapiecage unique.
const
GateStatusSuccess = NTSTATUS(0);
GateAlgEcdsaP256 = 'ECDSA_P256';
GateBlobEccPublic = 'ECCPUBLICBLOB';
GateBlobLen = 72;
GateSigLen = 64;
function GateOpenAlg(out phAlgorithm: Pointer; pszAlgId, pszImplementation: PWideChar;
dwFlags: ULONG): NTSTATUS; stdcall; external 'bcrypt.dll' name 'BCryptOpenAlgorithmProvider';
function GateCloseAlg(hAlgorithm: Pointer; dwFlags: ULONG): NTSTATUS; stdcall;
external 'bcrypt.dll' name 'BCryptCloseAlgorithmProvider';
function GateImportKey(hAlgorithm, hImportKey: Pointer; pszBlobType: PWideChar;
out phKey: Pointer; pbInput: PByte; cbInput, dwFlags: ULONG): NTSTATUS; stdcall;
external 'bcrypt.dll' name 'BCryptImportKeyPair';
function GateDestroyKey(hKey: Pointer): NTSTATUS; stdcall;
external 'bcrypt.dll' name 'BCryptDestroyKey';
function GateVerifySig(hKey, pPaddingInfo: Pointer; pbHash: PByte; cbHash: ULONG;
pbSignature: PByte; cbSignature, dwFlags: ULONG): NTSTATUS; stdcall;
external 'bcrypt.dll' name 'BCryptVerifySignature';
function GateB64Url(const AText: string): TBytes;
var
S: string;
begin
S := AText.Replace('-', '+').Replace('_', '/');
while Length(S) mod 4 <> 0 do
S := S + '=';
try
Result := TNetEncoding.Base64.DecodeStringToBytes(S);
except
Result := nil;
end;
end;
function GateSignatureHolds(const AKey, AMsg, ASig: TBytes): Boolean;
var
LAlg, LKey: Pointer;
LSha: THashSHA2;
LDigest: TBytes;
begin
Result := False;
if (Length(AKey) <> GateBlobLen) or (Length(ASig) <> GateSigLen) or
(Length(AMsg) = 0) then
Exit;
if GateOpenAlg(LAlg, GateAlgEcdsaP256, nil, 0) <> GateStatusSuccess then
Exit;
try
if GateImportKey(LAlg, nil, GateBlobEccPublic, LKey, @AKey[0],
GateBlobLen, 0) <> GateStatusSuccess then
Exit;
try
LSha := THashSHA2.Create(THashSHA2.TSHA2Version.SHA256);
LSha.Update(AMsg);
LDigest := LSha.HashAsBytes;
Result := GateVerifySig(LKey, nil, @LDigest[0], Length(LDigest),
@ASig[0], GateSigLen, 0) = GateStatusSuccess;
finally
GateDestroyKey(LKey);
end;
finally
GateCloseAlg(LAlg, 0);
end;
end;
// La meme regle d'acceptation que PM.Licence, reecrite : signature valable,
// adresse presente, empreinte presente ET egale a celle attendue. AMachine est
// un parametre pour que l'auto-test puisse la fixer — une empreinte reelle
// change d'un poste a l'autre et ne ferait pas un vecteur.
function GateAccepts(const AKey: TBytes; const ALicence, AMachine: string): Boolean;
var
LDot: Integer;
LMsg, LSig: TBytes;
LVal: TJSONValue;
LMachine, LEmail: string;
begin
Result := False;
LDot := Pos('.', ALicence);
if (LDot < 2) or (LDot = Length(ALicence)) then
Exit;
LMsg := GateB64Url(Copy(ALicence, 1, LDot - 1));
LSig := GateB64Url(Copy(ALicence, LDot + 1, MaxInt));
// La signature d'abord : on ne lit pas une charge utile qui ne vient pas de
// l'editeur.
if not GateSignatureHolds(AKey, LMsg, LSig) then
Exit;
LVal := TJSONObject.ParseJSONValue(TEncoding.UTF8.GetString(LMsg));
if LVal = nil then
Exit;
try
if not (LVal is TJSONObject) then
Exit;
LEmail := TJSONObject(LVal).GetValue<string>('e', '');
LMachine := LowerCase(TJSONObject(LVal).GetValue<string>('m', ''));
finally
LVal.Free;
end;
Result := (LEmail <> '') and (LMachine <> '') and
SameText(LMachine, AMachine);
end;
var
GateOpen: Boolean = False;
function ApiLicenceOk: Boolean;
begin
if GateOpen then
Exit(True);
GateOpen := GateAccepts(LicencePublicKey,
Trim(GetPref(LicencePrefKey)),
MachineFingerprint);
Result := GateOpen;
end;
// ===== Auto-test =============================================================
procedure SelfTestLicenceGate;
const
// Paire jetable, privee jamais ecrite : la licence ci-dessous est liee a
// l'empreinte fixe 0123456789abcdef.
GateTestKey: array[0..71] of Byte = (
$45, $43, $53, $31, $20, $00, $00, $00, $5D, $7C, $98, $73,
$08, $66, $2E, $01, $38, $95, $9B, $57, $ED, $14, $E7, $15,
$D8, $54, $4B, $F9, $A9, $A0, $D8, $25, $44, $11, $75, $63,
$F5, $B8, $ED, $D0, $97, $13, $C3, $E6, $3D, $64, $B5, $D0,
$7F, $83, $2D, $8B, $E4, $2F, $56, $17, $A9, $7A, $1D, $90,
$EF, $95, $8A, $9F, $D4, $D3, $C5, $34, $22, $7B, $F3, $D8
);
GateTestLicence =
'eyJuIjoiR2F0ZSIsImUiOiJnYXRlQHRlc3QubG9jYWwiLCJkIjoiMjAyNi0wOS0xNiIsIm0iOiIwMTIzNDU2Nzg5YWJjZGVmIn0.' +
'3LuJ7UGsEw3M3v6UmuUcjNRB5FWGF5Y8clLy1cKQtHXZ9O3foW7woVCuN1F9JD68N1DfILwFr2wT9OfUDt_pPw';
GateTestMachine = '0123456789abcdef';
var
LKey: TBytes;
LTampered: string;
begin
SetLength(LKey, GateBlobLen);
Move(GateTestKey[0], LKey[0], GateBlobLen);
// LE SENS QUI COMPTE LE PLUS : une deuxieme couche qui refuserait tout
// bloquerait chaque client licencie. Ce cas-la d'abord.
if not GateAccepts(LKey, GateTestLicence, GateTestMachine) then
raise Exception.Create('Auto-test 2e couche ECHOUE : une licence valable est refusee.');
if GateAccepts(LKey, GateTestLicence, 'ffffffffffffffff') then
raise Exception.Create('Auto-test 2e couche ECHOUE : une licence d''un autre poste est acceptee.');
LTampered := GateTestLicence;
LTampered[10] := Chr(Ord(LTampered[10]) xor 1);
if GateAccepts(LKey, LTampered, GateTestMachine) then
raise Exception.Create('Auto-test 2e couche ECHOUE : une licence trafiquee est acceptee.');
if GateAccepts(LKey, '', GateTestMachine) or
GateAccepts(LKey, 'nimportequoi', GateTestMachine) then
raise Exception.Create('Auto-test 2e couche ECHOUE : du charabia est accepte.');
end;
initialization
SelfTestLicenceGate;
end.
+17
View File
@@ -44,6 +44,9 @@ var
implementation implementation
uses
PM.LicenceGate, PM.JSON;
constructor TPMRouter.Create; constructor TPMRouter.Create;
begin begin
inherited; inherited;
@@ -86,6 +89,20 @@ begin
LMatch := LRoute.Regex.Match(LPath); LMatch := LRoute.Regex.Match(LPath);
if LMatch.Success then if LMatch.Success then
begin begin
// DEUXIEME COUCHE DE LICENCE : ici, et seulement ici. Seules les routes
// de l'API arrivent a cette ligne — les fichiers de l'ecran d'activation
// passent par TryServeEmbedded, qui n'est pas garde, sinon l'ecran qui
// permet de s'activer ne pourrait plus se charger.
//
// LE MEME 404 QU'UNE ROUTE INEXISTANTE, AU CARACTERE PRES. Un corps vide
// ne suffisait pas : Indy le remplace par sa propre page, qui se
// distinguait du JSON d'une route inconnue — et revelait donc quelles
// routes existent. Refuser doit etre indiscernable de ne rien avoir.
if not ApiLicenceOk then
begin
TJSONHelper.SendError(AResponse, 404, 'Not found');
Exit(True);
end;
SetLength(LParams, LMatch.Groups.Count - 1); SetLength(LParams, LMatch.Groups.Count - 1);
for I := 1 to LMatch.Groups.Count - 1 do for I := 1 to LMatch.Groups.Count - 1 do
LParams[I - 1] := LMatch.Groups[I].Value; LParams[I - 1] := LMatch.Groups[I].Value;
@@ -69,6 +69,15 @@ begin
CloseHandle(_Mutex); CloseHandle(_Mutex);
_Mutex := 0; _Mutex := 0;
end; end;
// CEDER LE PREMIER PLAN AVANT DE REVEILLER L'AUTRE. C'est NOUS qui venons de
// recevoir le double-clic de l'utilisateur, donc nous seuls avons le droit de
// passer devant. Sans cette cession, l'instance deja lancee — qui n'a recu
// aucune entree — se voit refuser SetForegroundWindow par Windows : sa
// fenetre se montre DERRIERE les autres, avec seulement son icone dans la
// barre des taches. Mesure avant correctif : visible, non minimisee, pas au
// premier plan. Tous processus parce que le PID de l'autre instance n'est pas connu
// ici ; le droit cede expire a la prochaine entree utilisateur.
AllowSetForegroundWindow(DWORD(-1)); // ASFW_ANY, absent de Winapi.Windows
PostMessage(HWND_BROADCAST, WM_PMShowMessage, 0, 0); PostMessage(HWND_BROADCAST, WM_PMShowMessage, 0, 0);
Result := False; Result := False;
end; end;
+131 -2
View File
@@ -35,7 +35,7 @@ uses
FMX.TMSFNCEdgeWebBrowser, FMX.TMSFNCEdgeWebBrowser,
{$ENDIF} {$ENDIF}
PM.HTTPServer, PM.Bridge, PM.QuickUnlock, PM.PinUnlock, PM.UserPrefs, PM.Licence, PM.AutoStart, PM.HTTPServer, PM.Bridge, PM.QuickUnlock, PM.PinUnlock, PM.UserPrefs, PM.Licence, PM.AutoStart,
PM.Favicon, PM.Favicon, DelphiZXingQRCode,
FMX.Platform.Win, FMX.Menus; // WindowHandleToPlatform → HWND for visibility check FMX.Platform.Win, FMX.Menus; // WindowHandleToPlatform → HWND for visibility check
const const
// Bump on each release. Surfaced to JS via cmd://app/version, displayed // Bump on each release. Surfaced to JS via cmd://app/version, displayed
@@ -314,6 +314,20 @@ begin
FFileSaveChunks := TDictionary<string, TStringBuilder>.Create; FFileSaveChunks := TDictionary<string, TStringBuilder>.Create;
FBridge.OnSystemLock := BridgeSystemLock; FBridge.OnSystemLock := BridgeSystemLock;
FBridge.OnTrayRestore := BridgeTrayRestore; FBridge.OnTrayRestore := BridgeTrayRestore;
// Changement fait sur la barrette elle-meme : l'onglet se relit (fillbar/get).
FBridge.OnFillBarChanged :=
procedure
begin
// Pas avant l'init de WebView2 : RestoreLazyBar passe ici au demarrage.
if FBrowserInitialized then
WebBrowser.ExecuteJavaScript('if(window.fillBarRequest)fillBarRequest()');
end;
FBridge.OnFillBarSettings :=
procedure
begin
WebBrowser.ExecuteJavaScript(
'if(window.Bridge&&Bridge.onOpenFillBarSettings)Bridge.onOpenFillBarSettings()');
end;
FBridge.OnLockRequest := BridgeLockRequest; FBridge.OnLockRequest := BridgeLockRequest;
FBridge.OnQuit := BridgeQuit; FBridge.OnQuit := BridgeQuit;
FBridge.OnAutofillRequest := BridgeAutofillRequest; FBridge.OnAutofillRequest := BridgeAutofillRequest;
@@ -1323,6 +1337,42 @@ begin
'Bridge.onPrefResult("' + LEsc + '#has","' + LSet + '")'); 'Bridge.onPrefResult("' + LEsc + '#has","' + LSet + '")');
end end
// ---- Barrette (Fill bar) : reglages depuis Settings -> Fill bar ---------
// Rien de secret ici : quels boutons, icones ou mots, opacite, allumee.
else if ACmd = 'fillbar/get' then
begin
var LFb := TJSONObject.Create;
try
LFb.AddPair('on', TJSONBool.Create(FBridge.LazyBarVisible));
LFb.AddPair('buttons', PM.UserPrefs.GetPref('lazyButtons'));
LFb.AddPair('icons', TJSONBool.Create(PM.UserPrefs.GetPref('lazyIcons') = '1'));
LFb.AddPair('alpha', PM.UserPrefs.GetPref('lazyAlphaPct'));
WebBrowser.ExecuteJavaScript(
'if(window.Bridge&&Bridge.onFillBar)Bridge.onFillBar(' + LFb.ToJSON + ')');
finally
LFb.Free;
end;
end
else if ACmd = 'fillbar/set' then
begin
PM.UserPrefs.SetPref('lazyButtons', GetParam('buttons'));
if GetParam('icons') = '1' then PM.UserPrefs.SetPref('lazyIcons', '1')
else PM.UserPrefs.SetPref('lazyIcons', '0');
var LAlpha := StrToIntDef(GetParam('alpha'), 60);
if (LAlpha >= 25) and (LAlpha <= 100) then
PM.UserPrefs.SetPref('lazyAlphaPct', IntToStr(LAlpha));
LogLine('fillbar/set: ' + GetParam('buttons') + ' icons=' + GetParam('icons') +
' alpha=' + GetParam('alpha') + ' on=' + GetParam('on'));
if GetParam('on') = '1' then
begin
if FBridge.LazyBarVisible then FBridge.ReloadLazyBar
else FBridge.SetLazyBar(True);
end
else
FBridge.SetLazyBar(False);
end
else if ACmd = 'prefs/set' then else if ACmd = 'prefs/set' then
begin begin
var LKey := GetParam('key'); var LKey := GetParam('key');
@@ -1330,6 +1380,72 @@ begin
PM.UserPrefs.SetPref(LKey, GetParam('value')); PM.UserPrefs.SetPref(LKey, GetParam('value'));
end end
// ---- QR des reglages de synchro, pour le telephone ------------------
// L'EXE FABRIQUE LE QR LUI-MEME : l'URL et le jeton se lisent ici, dans les
// prefs DPAPI, et seule la matrice noir/blanc part vers la page - le jeton
// ne transite pas en clair par le moteur de rendu (meme raison que
// prefs/has). Le mot de passe de synchro n'y est JAMAIS : un QR se
// photographie par-dessus l'epaule.
// UN LIEN pmserver://sync?u=&t= ET NON DU TEXTE. Le scanner du telephone
// envoie tout texte a une recherche web (Google, Chrome) - le jeton serait
// parti chez Google a un appui pres. Un lien a schema propre n'a qu'une
// application pour l'ouvrir : la notre.
else if ACmd = 'sync/qr' then
begin
var LQrUrl := PM.UserPrefs.GetPref('syncUrl');
var LQrTok := PM.UserPrefs.GetPref('syncPwd');
var LBits := '';
var LSize := 0;
if (LQrUrl <> '') and (LQrTok <> '') then
begin
var LQr := TDelphiZXingQRCode.Create;
var LSb := TStringBuilder.Create;
try
LQr.Encoding := qrUTF8NoBOM;
LQr.QuietZone := 4;
// LE PLUS COURT POSSIBLE : moins de caracteres = modules plus gros,
// lisibles par une camera. L'adresse du depot plutot que l'URL d'API
// (le telephone la rallonge a l'enregistrement), et seuls les
// caracteres qui casseraient la requete sont echappes - TNetEncoding
// changeait chaque ":" et "/" en trois caracteres.
var LShort := LQrUrl;
var LApi := Pos('/api/v1/repos/', LShort);
// GitHub : l'adresse du depot est sur github.com, l'API sur api.github.com.
if StartsText('https://api.github.com/repos/', LShort) and
EndsText('/contents/vault-sync.json', LShort) then
LShort := 'https://github.com/' +
Copy(LShort, Length('https://api.github.com/repos/') + 1,
Length(LShort) - Length('https://api.github.com/repos/') -
Length('/contents/vault-sync.json'))
else if (LApi > 0) and EndsText('/contents/vault-sync.json', LShort) then
LShort := Copy(LShort, 1, LApi) +
Copy(LShort, LApi + Length('/api/v1/repos/'),
Length(LShort) - LApi - Length('/api/v1/repos/') - Length('/contents/vault-sync.json') + 1);
LShort := StringReplace(LShort, '%', '%25', [rfReplaceAll]);
LShort := StringReplace(LShort, '&', '%26', [rfReplaceAll]);
LShort := StringReplace(LShort, '#', '%23', [rfReplaceAll]);
LShort := StringReplace(LShort, '+', '%2B', [rfReplaceAll]);
LShort := StringReplace(LShort, ' ', '%20', [rfReplaceAll]);
LQr.Data := 'pmserver://sync?u=' + LShort + '&t=' + TNetEncoding.URL.Encode(LQrTok);
LSize := LQr.Rows;
for var R := 0 to LQr.Rows - 1 do
for var C := 0 to LQr.Columns - 1 do
if LQr.IsBlack[R, C] then LSb.Append('1') else LSb.Append('0');
LBits := LSb.ToString;
finally
LSb.Free;
LQr.Free;
end;
end;
if LSize > 0 then
LogLine('sync/qr: ' + IntToStr(LSize) + ' modules')
else
LogLine('sync/qr: URL or token not set');
WebBrowser.ExecuteJavaScript(
'if(window.Bridge&&Bridge.onSyncQr)Bridge.onSyncQr(' + IntToStr(LSize) +
',"' + LBits + '")');
end
// ---- Licence hors ligne (PM.Licence) --------------------------------- // ---- Licence hors ligne (PM.Licence) ---------------------------------
// cmd://licence/status -> Bridge.onLicenceResult(ok, porteur) // cmd://licence/status -> Bridge.onLicenceResult(ok, porteur)
// cmd://licence/activate?key=<...> -> idem, apres verification + rangement // cmd://licence/activate?key=<...> -> idem, apres verification + rangement
@@ -1362,6 +1478,15 @@ begin
begin begin
LLicOk := PM.Licence.IsLicensed; LLicOk := PM.Licence.IsLicensed;
LLicInfo := PM.Licence.LicenceInfo; LLicInfo := PM.Licence.LicenceInfo;
{$IFDEF LICENCE_TEST_SKIP_SCREEN}
// EXE D'ESSAI UNIQUEMENT : simule une 1re couche rapiecee, pour eprouver
// la 2e depuis l'application elle-meme. A la COMPILATION et jamais par un
// reglage — un interrupteur dans config.txt, que n'importe qui peut
// creer a cote de l'exe, ferait sauter la 1re couche sans rapiecage.
// La 2e couche, elle, verifie toujours la vraie licence : c'est l'essai.
LLicOk := True;
LogLine('LICENCE TEST BUILD: ecran d''activation saute (1re couche simulee rapiecee)');
{$ENDIF}
end; end;
// Le nom, le courriel et la date viennent d'une charge utile QUE NOUS AVONS // Le nom, le courriel et la date viennent d'une charge utile QUE NOUS AVONS
// SIGNEE, mais ils sont interpoles dans du JavaScript : on les echappe // SIGNEE, mais ils sont interpoles dans du JavaScript : on les echappe
@@ -1504,7 +1629,9 @@ begin
// remplace l'authentification Basic, le corps d'un PUT est du JSON que JS // remplace l'authentification Basic, le corps d'un PUT est du JSON que JS
// a deja mis en forme (le sha y voyage, pas dans un If-Match), et le test // a deja mis en forme (le sha y voyage, pas dans un If-Match), et le test
// de connexion se fait par GET - l'API des contenus ne repond pas a HEAD. // de connexion se fait par GET - l'API des contenus ne repond pas a HEAD.
var LGitea := LUrl.ToLower.Contains('/api/v1/repos/'); // GitHub parle la meme API des contenus : meme traitement.
var LGitea := LUrl.ToLower.Contains('/api/v1/repos/') or
LUrl.ToLower.Contains('api.github.com/repos/');
TThread.CreateAnonymousThread( TThread.CreateAnonymousThread(
procedure procedure
var var
@@ -1527,6 +1654,8 @@ begin
try try
LHttp.ConnectionTimeout := 10000; LHttp.ConnectionTimeout := 10000;
LHttp.ResponseTimeout := 30000; LHttp.ResponseTimeout := 30000;
// GitHub REFUSE toute requete sans User-Agent (403) ; Gitea l'ignore.
LHttp.UserAgent := 'PMServer';
// "token <PAT>" et non "Bearer" : c'est la forme que Gitea attend // "token <PAT>" et non "Bearer" : c'est la forme que Gitea attend
// d'un jeton d'acces personnel, et l'autre donne un 401 muet. // d'un jeton d'acces personnel, et l'autre donne un 401 muet.
if LGitea then if LGitea then

Some files were not shown because too many files have changed in this diff Show More