├── COPYING ├── README.example.png ├── README.md ├── emacs-commands.el ├── load.el ├── qrencode ├── bstream.el ├── codeword.el ├── encode.el ├── input.el ├── mask.el ├── matrix.el ├── modes.el └── qrspec.el ├── rs-ecc ├── bch-ecc.el ├── galois.el └── rs-ecc.el └── test.el /COPYING: -------------------------------------------------------------------------------- 1 | GNU GENERAL PUBLIC LICENSE 2 | Version 2, June 1991 3 | 4 | Copyright (C) 1989, 1991 Free Software Foundation, Inc. 5 | 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 6 | Everyone is permitted to copy and distribute verbatim copies 7 | of this license document, but changing it is not allowed. 8 | 9 | Preamble 10 | 11 | The licenses for most software are designed to take away your 12 | freedom to share and change it. By contrast, the GNU General Public 13 | License is intended to guarantee your freedom to share and change free 14 | software--to make sure the software is free for all its users. This 15 | General Public License applies to most of the Free Software 16 | Foundation's software and to any other program whose authors commit to 17 | using it. (Some other Free Software Foundation software is covered by 18 | the GNU Library General Public License instead.) You can apply it to 19 | your programs, too. 20 | 21 | When we speak of free software, we are referring to freedom, not 22 | price. Our General Public Licenses are designed to make sure that you 23 | have the freedom to distribute copies of free software (and charge for 24 | this service if you wish), that you receive source code or can get it 25 | if you want it, that you can change the software or use pieces of it 26 | in new free programs; and that you know you can do these things. 27 | 28 | To protect your rights, we need to make restrictions that forbid 29 | anyone to deny you these rights or to ask you to surrender the rights. 30 | These restrictions translate to certain responsibilities for you if you 31 | distribute copies of the software, or if you modify it. 32 | 33 | For example, if you distribute copies of such a program, whether 34 | gratis or for a fee, you must give the recipients all the rights that 35 | you have. You must make sure that they, too, receive or can get the 36 | source code. And you must show them these terms so they know their 37 | rights. 38 | 39 | We protect your rights with two steps: (1) copyright the software, and 40 | (2) offer you this license which gives you legal permission to copy, 41 | distribute and/or modify the software. 42 | 43 | Also, for each author's protection and ours, we want to make certain 44 | that everyone understands that there is no warranty for this free 45 | software. If the software is modified by someone else and passed on, we 46 | want its recipients to know that what they have is not the original, so 47 | that any problems introduced by others will not reflect on the original 48 | authors' reputations. 49 | 50 | Finally, any free program is threatened constantly by software 51 | patents. We wish to avoid the danger that redistributors of a free 52 | program will individually obtain patent licenses, in effect making the 53 | program proprietary. To prevent this, we have made it clear that any 54 | patent must be licensed for everyone's free use or not licensed at all. 55 | 56 | The precise terms and conditions for copying, distribution and 57 | modification follow. 58 | 59 | GNU GENERAL PUBLIC LICENSE 60 | TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 61 | 62 | 0. This License applies to any program or other work which contains 63 | a notice placed by the copyright holder saying it may be distributed 64 | under the terms of this General Public License. The "Program", below, 65 | refers to any such program or work, and a "work based on the Program" 66 | means either the Program or any derivative work under copyright law: 67 | that is to say, a work containing the Program or a portion of it, 68 | either verbatim or with modifications and/or translated into another 69 | language. (Hereinafter, translation is included without limitation in 70 | the term "modification".) Each licensee is addressed as "you". 71 | 72 | Activities other than copying, distribution and modification are not 73 | covered by this License; they are outside its scope. The act of 74 | running the Program is not restricted, and the output from the Program 75 | is covered only if its contents constitute a work based on the 76 | Program (independent of having been made by running the Program). 77 | Whether that is true depends on what the Program does. 78 | 79 | 1. You may copy and distribute verbatim copies of the Program's 80 | source code as you receive it, in any medium, provided that you 81 | conspicuously and appropriately publish on each copy an appropriate 82 | copyright notice and disclaimer of warranty; keep intact all the 83 | notices that refer to this License and to the absence of any warranty; 84 | and give any other recipients of the Program a copy of this License 85 | along with the Program. 86 | 87 | You may charge a fee for the physical act of transferring a copy, and 88 | you may at your option offer warranty protection in exchange for a fee. 89 | 90 | 2. You may modify your copy or copies of the Program or any portion 91 | of it, thus forming a work based on the Program, and copy and 92 | distribute such modifications or work under the terms of Section 1 93 | above, provided that you also meet all of these conditions: 94 | 95 | a) You must cause the modified files to carry prominent notices 96 | stating that you changed the files and the date of any change. 97 | 98 | b) You must cause any work that you distribute or publish, that in 99 | whole or in part contains or is derived from the Program or any 100 | part thereof, to be licensed as a whole at no charge to all third 101 | parties under the terms of this License. 102 | 103 | c) If the modified program normally reads commands interactively 104 | when run, you must cause it, when started running for such 105 | interactive use in the most ordinary way, to print or display an 106 | announcement including an appropriate copyright notice and a 107 | notice that there is no warranty (or else, saying that you provide 108 | a warranty) and that users may redistribute the program under 109 | these conditions, and telling the user how to view a copy of this 110 | License. (Exception: if the Program itself is interactive but 111 | does not normally print such an announcement, your work based on 112 | the Program is not required to print an announcement.) 113 | 114 | These requirements apply to the modified work as a whole. If 115 | identifiable sections of that work are not derived from the Program, 116 | and can be reasonably considered independent and separate works in 117 | themselves, then this License, and its terms, do not apply to those 118 | sections when you distribute them as separate works. But when you 119 | distribute the same sections as part of a whole which is a work based 120 | on the Program, the distribution of the whole must be on the terms of 121 | this License, whose permissions for other licensees extend to the 122 | entire whole, and thus to each and every part regardless of who wrote it. 123 | 124 | Thus, it is not the intent of this section to claim rights or contest 125 | your rights to work written entirely by you; rather, the intent is to 126 | exercise the right to control the distribution of derivative or 127 | collective works based on the Program. 128 | 129 | In addition, mere aggregation of another work not based on the Program 130 | with the Program (or with a work based on the Program) on a volume of 131 | a storage or distribution medium does not bring the other work under 132 | the scope of this License. 133 | 134 | 3. You may copy and distribute the Program (or a work based on it, 135 | under Section 2) in object code or executable form under the terms of 136 | Sections 1 and 2 above provided that you also do one of the following: 137 | 138 | a) Accompany it with the complete corresponding machine-readable 139 | source code, which must be distributed under the terms of Sections 140 | 1 and 2 above on a medium customarily used for software interchange; or, 141 | 142 | b) Accompany it with a written offer, valid for at least three 143 | years, to give any third party, for a charge no more than your 144 | cost of physically performing source distribution, a complete 145 | machine-readable copy of the corresponding source code, to be 146 | distributed under the terms of Sections 1 and 2 above on a medium 147 | customarily used for software interchange; or, 148 | 149 | c) Accompany it with the information you received as to the offer 150 | to distribute corresponding source code. (This alternative is 151 | allowed only for noncommercial distribution and only if you 152 | received the program in object code or executable form with such 153 | an offer, in accord with Subsection b above.) 154 | 155 | The source code for a work means the preferred form of the work for 156 | making modifications to it. For an executable work, complete source 157 | code means all the source code for all modules it contains, plus any 158 | associated interface definition files, plus the scripts used to 159 | control compilation and installation of the executable. However, as a 160 | special exception, the source code distributed need not include 161 | anything that is normally distributed (in either source or binary 162 | form) with the major components (compiler, kernel, and so on) of the 163 | operating system on which the executable runs, unless that component 164 | itself accompanies the executable. 165 | 166 | If distribution of executable or object code is made by offering 167 | access to copy from a designated place, then offering equivalent 168 | access to copy the source code from the same place counts as 169 | distribution of the source code, even though third parties are not 170 | compelled to copy the source along with the object code. 171 | 172 | 4. You may not copy, modify, sublicense, or distribute the Program 173 | except as expressly provided under this License. Any attempt 174 | otherwise to copy, modify, sublicense or distribute the Program is 175 | void, and will automatically terminate your rights under this License. 176 | However, parties who have received copies, or rights, from you under 177 | this License will not have their licenses terminated so long as such 178 | parties remain in full compliance. 179 | 180 | 5. You are not required to accept this License, since you have not 181 | signed it. However, nothing else grants you permission to modify or 182 | distribute the Program or its derivative works. These actions are 183 | prohibited by law if you do not accept this License. Therefore, by 184 | modifying or distributing the Program (or any work based on the 185 | Program), you indicate your acceptance of this License to do so, and 186 | all its terms and conditions for copying, distributing or modifying 187 | the Program or works based on it. 188 | 189 | 6. Each time you redistribute the Program (or any work based on the 190 | Program), the recipient automatically receives a license from the 191 | original licensor to copy, distribute or modify the Program subject to 192 | these terms and conditions. You may not impose any further 193 | restrictions on the recipients' exercise of the rights granted herein. 194 | You are not responsible for enforcing compliance by third parties to 195 | this License. 196 | 197 | 7. If, as a consequence of a court judgment or allegation of patent 198 | infringement or for any other reason (not limited to patent issues), 199 | conditions are imposed on you (whether by court order, agreement or 200 | otherwise) that contradict the conditions of this License, they do not 201 | excuse you from the conditions of this License. If you cannot 202 | distribute so as to satisfy simultaneously your obligations under this 203 | License and any other pertinent obligations, then as a consequence you 204 | may not distribute the Program at all. For example, if a patent 205 | license would not permit royalty-free redistribution of the Program by 206 | all those who receive copies directly or indirectly through you, then 207 | the only way you could satisfy both it and this License would be to 208 | refrain entirely from distribution of the Program. 209 | 210 | If any portion of this section is held invalid or unenforceable under 211 | any particular circumstance, the balance of the section is intended to 212 | apply and the section as a whole is intended to apply in other 213 | circumstances. 214 | 215 | It is not the purpose of this section to induce you to infringe any 216 | patents or other property right claims or to contest validity of any 217 | such claims; this section has the sole purpose of protecting the 218 | integrity of the free software distribution system, which is 219 | implemented by public license practices. Many people have made 220 | generous contributions to the wide range of software distributed 221 | through that system in reliance on consistent application of that 222 | system; it is up to the author/donor to decide if he or she is willing 223 | to distribute software through any other system and a licensee cannot 224 | impose that choice. 225 | 226 | This section is intended to make thoroughly clear what is believed to 227 | be a consequence of the rest of this License. 228 | 229 | 8. If the distribution and/or use of the Program is restricted in 230 | certain countries either by patents or by copyrighted interfaces, the 231 | original copyright holder who places the Program under this License 232 | may add an explicit geographical distribution limitation excluding 233 | those countries, so that distribution is permitted only in or among 234 | countries not thus excluded. In such case, this License incorporates 235 | the limitation as if written in the body of this License. 236 | 237 | 9. The Free Software Foundation may publish revised and/or new versions 238 | of the General Public License from time to time. Such new versions will 239 | be similar in spirit to the present version, but may differ in detail to 240 | address new problems or concerns. 241 | 242 | Each version is given a distinguishing version number. If the Program 243 | specifies a version number of this License which applies to it and "any 244 | later version", you have the option of following the terms and conditions 245 | either of that version or of any later version published by the Free 246 | Software Foundation. If the Program does not specify a version number of 247 | this License, you may choose any version ever published by the Free Software 248 | Foundation. 249 | 250 | 10. If you wish to incorporate parts of the Program into other free 251 | programs whose distribution conditions are different, write to the author 252 | to ask for permission. For software which is copyrighted by the Free 253 | Software Foundation, write to the Free Software Foundation; we sometimes 254 | make exceptions for this. Our decision will be guided by the two goals 255 | of preserving the free status of all derivatives of our free software and 256 | of promoting the sharing and reuse of software generally. 257 | 258 | NO WARRANTY 259 | 260 | 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY 261 | FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN 262 | OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES 263 | PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED 264 | OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 265 | MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS 266 | TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE 267 | PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, 268 | REPAIR OR CORRECTION. 269 | 270 | 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING 271 | WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR 272 | REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, 273 | INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING 274 | OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED 275 | TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY 276 | YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER 277 | PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE 278 | POSSIBILITY OF SUCH DAMAGES. 279 | 280 | END OF TERMS AND CONDITIONS 281 | 282 | How to Apply These Terms to Your New Programs 283 | 284 | If you develop a new program, and you want it to be of the greatest 285 | possible use to the public, the best way to achieve this is to make it 286 | free software which everyone can redistribute and change under these terms. 287 | 288 | To do so, attach the following notices to the program. It is safest 289 | to attach them to the start of each source file to most effectively 290 | convey the exclusion of warranty; and each file should have at least 291 | the "copyright" line and a pointer to where the full notice is found. 292 | 293 | 294 | Copyright (C) 295 | 296 | This program is free software; you can redistribute it and/or modify 297 | it under the terms of the GNU General Public License as published by 298 | the Free Software Foundation; either version 2 of the License, or 299 | (at your option) any later version. 300 | 301 | This program is distributed in the hope that it will be useful, 302 | but WITHOUT ANY WARRANTY; without even the implied warranty of 303 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 304 | GNU General Public License for more details. 305 | 306 | You should have received a copy of the GNU General Public License 307 | along with this program; if not, write to the Free Software 308 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 309 | 310 | 311 | Also add information on how to contact you by electronic and paper mail. 312 | 313 | If the program is interactive, make it output a short notice like this 314 | when it starts in an interactive mode: 315 | 316 | Gnomovision version 69, Copyright (C) year name of author 317 | Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. 318 | This is free software, and you are welcome to redistribute it 319 | under certain conditions; type `show c' for details. 320 | 321 | The hypothetical commands `show w' and `show c' should show the appropriate 322 | parts of the General Public License. Of course, the commands you use may 323 | be called something other than `show w' and `show c'; they could even be 324 | mouse-clicks or menu items--whatever suits your program. 325 | 326 | You should also get your employer (if you work as a programmer) or your 327 | school, if any, to sign a "copyright disclaimer" for the program, if 328 | necessary. Here is a sample; alter the names: 329 | 330 | Yoyodyne, Inc., hereby disclaims all copyright interest in the program 331 | `Gnomovision' (which makes passes at compilers) written by James Hacker. 332 | 333 | , 1 April 1989 334 | Ty Coon, President of Vice 335 | 336 | This General Public License does not permit incorporating your program into 337 | proprietary programs. If your program is a subroutine library, you may 338 | consider it more useful to permit linking proprietary applications with the 339 | library. If this is what you want to do, use the GNU Library General 340 | Public License instead of this License. 341 | -------------------------------------------------------------------------------- /README.example.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/thesoftwarebin/el-qrencode/7bf0d9dcace49f863576f8bebf4ee17c9b62d802/README.example.png -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | el-qrencode 1.0-alpha 2 | ===================== 3 | 4 | This is a QR code generator for Emacs, written in Emacs Lisp. It's a 5 | CommonLISP-to-EmacsLISP port of the cl-qrencode package by jnjcc, see 6 | `Copyright and License` at bottom for more details. 7 | 8 | ![usage example](https://github.com/thesoftwarebin/el-qrencode/blob/master/README.example.png) 9 | 10 | Please consider this EmacsLISP version as an alpha-quality hobby 11 | project: future version may add, rename or remove functions. 12 | 13 | If you like it and have bugfixes or enhancements to contribute, please 14 | do! Patches and forks are more than welcome, please read also the 15 | `Proposed/Needed Future Enhancements` section below. 16 | 17 | Usage example 18 | ------------- 19 | 20 | In the following the Emacs keyboard notation will be used: for example 21 | `RET` means press Return, `M-x` means press Alt+x, `C-x` means press 22 | Ctrl+x. For further details see 23 | [the Emacs manual, section User Input](https://www.gnu.org/software/emacs/manual/html_node/emacs/User-Input.html). 24 | 25 | Here's a basic usage example: 26 | 27 | - start Emacs 28 | - `M-x cd RET RET` 29 | - `M-x load-file RET load.el RET` 30 | - put the cursor in an empty buffer (like `*scratch*`) and 31 | type some example text like `hello qrencode!`. 32 | - mark the `hello qrencode!` with the mouse and type 33 | `M-x qrencode-region RET`: a QRcode has been generated 34 | in results buffer `*qrcode*` using ASCII characters 35 | - view the results buffer by typing `C-x b *qrcode*`, 36 | maybe use zoom-out (`C-x C-+`) to make it fit in your 37 | window 38 | 39 | Configuration 40 | ------------- 41 | 42 | You may tweak the `(defvar ...)` statements at top of 43 | `emacs-commands.el`. Most variables are rather self-explanatory, 44 | except the ones used for ASCII representation of the single 45 | black/white QR cell. 46 | 47 | Every cell is `qrencode-hzoom` characters large and `qrencode-vzoom` 48 | characters tall. I've set a default of `qrencode-hzoom`=2 because my 49 | default fonts are rather tall. 50 | 51 | Dependencies 52 | ------------ 53 | 54 | I tried to keep them to the bare minimum. You need to have at least 55 | the `cl` package. It works properly on Emacs 24.4, it's untested on 56 | other versions. 57 | 58 | Proposed/Needed Future Enhancements 59 | ----------------------------------- 60 | 61 | - better documentation of both the private and interactive functions 62 | - code refactoring: decorate private functions and classes with the 63 | `qrencode--` prefix 64 | - code refactoring: remove recursive functions (they forced me to 65 | tweak `max-specpdl-size` and `max-lisp-eval-depth` in `load.el`) 66 | - code refactoring: turn this into an Emacs package, so it might work 67 | with `M-x list-packages RET` and Emacs repositories (maybe 68 | [Melpa](http://melpa.org) or 69 | [Marmalade](https://marmalade-repo.org/)) 70 | - enhancement: generate an image containing the QR code; start with 71 | XPM format (built-in support in Emacs), add other formats if 72 | possible and not too hard (SVG?) 73 | - enhancement: build a separate module for Org mode that turns a 74 | timestamped Org task into a QRcode calendar event 75 | - (other suggestions welcome) 76 | 77 | Copyright and License 78 | --------------------- 79 | 80 | Original Common Lisp version: 81 | Copyright (c) 2011-2014 jnjcc, [Yste.org](http://www.yste.org) 82 | 83 | Port to Emacs Lisp: 84 | Copyright (c) 2015 Andrea Rossetti (http://andrear.altervista.org) 85 | 86 | This program is free software; you can redistribute it and/or modify 87 | it under the terms of the GNU General Public License as published by 88 | the Free Software Foundation; either version 2, or (at your option) 89 | any later version. Refer to the COPYING file in this same directory. 90 | -------------------------------------------------------------------------------- /emacs-commands.el: -------------------------------------------------------------------------------- 1 | (defvar qrencode-border 4) 2 | (defvar qrencode-hzoom 2) 3 | (defvar qrencode-vzoom 1) 4 | (defvar qrencode-buffer-name "*qrcode*") 5 | 6 | (defvar qrencode-use-faces t) 7 | 8 | (defvar qrencode-checker-char-black "#") 9 | (defvar qrencode-checker-char-white " " ) 10 | 11 | (defface qrencode-checker-black 12 | '((t (:background "black"))) 13 | "qrencode: black checker face" 14 | :group 'qrencode) 15 | 16 | (defface qrencode-checker-white 17 | '((t (:background "white"))) 18 | "qrencode: white checker face" 19 | :group 'qrencode) 20 | 21 | (defun qrencode-swap-black-white () 22 | (interactive) 23 | (psetf 24 | qrencode-checker-char-white qrencode-checker-char-black 25 | qrencode-checker-char-black qrencode-checker-char-white) 26 | (message "Now black is char \"%s\", white is char \"%s\"" 27 | qrencode-checker-char-black 28 | qrencode-checker-char-white)) 29 | 30 | (defun qrencode--insert-checker-at-point (blackp) 31 | (if qrencode-use-faces 32 | (progn 33 | (insert " ") 34 | (add-text-properties 35 | (1- (point)) (point) 36 | (list 37 | 'face 38 | (if blackp 'qrencode-checker-black 'qrencode-checker-white)))) 39 | (insert 40 | (if blackp 41 | qrencode-checker-char-black 42 | qrencode-checker-char-white)))) 43 | 44 | (defun qrencode--insert-checker (mtx i0 j0) 45 | (qrencode--insert-checker-at-point 46 | (if (and (>= i 0) (< i (length mtx)) (>= j 0) (< j (length (aref mtx i)))) 47 | (memq (aref (aref mtx j) i) '(:dark :fdark)) 48 | nil))) 49 | 50 | ;;;###autoload 51 | (defun qrencode-string (msg) 52 | "insert an ASCII QR in the current buffer" 53 | (interactive "sMessage to encode:") 54 | (let ((q (matrix 55 | (encode-symbol 56 | (with-temp-buffer 57 | (insert msg) 58 | (toggle-enable-multibyte-characters -1) 59 | (buffer-substring-no-properties (point-min) (point-max))) 60 | nil nil nil)))) 61 | (save-window-excursion 62 | (set-buffer (get-buffer-create qrencode-buffer-name)) 63 | (delete-region (point-min) (point-max)) 64 | (goto-char (point-min)) 65 | (loop for i from (- qrencode-border) to (+ qrencode-border (1- (length q))) do 66 | (dotimes (ivzoom qrencode-vzoom) 67 | (progn 68 | (loop for j from (- qrencode-border) to (+ qrencode-border (1- (length q))) do 69 | (dotimes 70 | (ihzoom qrencode-hzoom) 71 | (qrencode--insert-checker q i j))) 72 | (insert "\n")))) 73 | (goto-char (point-min))))) 74 | 75 | ;;;###autoload 76 | (defun qrencode-region (from to) 77 | (interactive "r") 78 | (when (region-active-p) 79 | (qrencode-string 80 | (buffer-substring-no-properties from to)))) 81 | -------------------------------------------------------------------------------- /load.el: -------------------------------------------------------------------------------- 1 | ;; -*- lexical-binding: t -*- 2 | 3 | ;; a dummy debug/trace function 4 | (if (not (fboundp 'dbg)) 5 | (defun dbg (&rest args))) 6 | 7 | (load-file "rs-ecc/bch-ecc.el") 8 | (load-file "rs-ecc/galois.el") 9 | (load-file "rs-ecc/rs-ecc.el") 10 | 11 | (load-file "qrencode/qrspec.el") 12 | (load-file "qrencode/bstream.el") 13 | (load-file "qrencode/codeword.el") 14 | (load-file "qrencode/encode.el") 15 | (load-file "qrencode/input.el") 16 | (load-file "qrencode/mask.el") 17 | (load-file "qrencode/matrix.el") 18 | (load-file "qrencode/modes.el") 19 | 20 | (load-file "emacs-commands.el") 21 | 22 | ;; raise memory limits, else Emacs will complain 23 | (setf max-specpdl-size 12000) 24 | (setf max-lisp-eval-depth 12000) 25 | -------------------------------------------------------------------------------- /qrencode/bstream.el: -------------------------------------------------------------------------------- 1 | ;; -*- lexical-binding: t -*- 2 | 3 | ;;;; Copyright (c) 2011-2014 jnjcc, Yste.org. All rights reserved. 4 | ;;;; 5 | ;;;; bit stream (a list of 0-1 values) utilities 6 | 7 | ;;(in-package #:cl-qrencode) 8 | 9 | (require 'cl) 10 | 11 | (defun bstream-logbitp (j i) (> (logand i (lsh 1 j)) 0)) 12 | 13 | (defun decimal->bstream (dec nbits) 14 | "using NBITS bits to encode decimal DEC" 15 | (let ((bstream nil)) 16 | (dotimes (i nbits) 17 | (if (bstream-logbitp i dec) 18 | (push 1 bstream) 19 | (push 0 bstream))) 20 | bstream)) 21 | 22 | (defun bstream->decimal (bstream nbits) 23 | (declare (type list bstream)) 24 | (let ((nbits (min nbits (length bstream))) 25 | (dec 0)) 26 | (dotimes (i nbits) 27 | (setf dec (+ (* dec 2) (nth i bstream)))) 28 | dec)) 29 | 30 | ;;; :numeric mode 31 | (defun group->decimal (values ndigits) 32 | "digit groups of length NDIGITS (1, 2 or 3) to decimal" 33 | (declare (type list values)) 34 | (case ndigits 35 | (1 (nth 0 values)) 36 | (2 (+ (* (nth 0 values) 10) (nth 1 values))) 37 | (3 (+ (* (nth 0 values) 100) (* (nth 1 values) 10) (nth 2 values))))) 38 | 39 | (defun final-digit-bits (n) 40 | "the final one or two digits are converted to 4 or 7 bits respectively" 41 | (case n 42 | (0 0) (1 4) (2 7))) 43 | 44 | (defun numeric->bstream (bytes) 45 | (declare (type list bytes)) 46 | (cl-labels ((num-value (byte) 47 | (byte-value :numeric byte))) 48 | (let ((values (mapcar #'num-value bytes)) 49 | (bstream nil)) 50 | (do ((v values (nthcdr 3 v))) 51 | ((null v) bstream) 52 | (case (length v) 53 | (1 ; only 1 digits left 54 | (setf bstream 55 | (append bstream (decimal->bstream (group->decimal v 1) 56 | (final-digit-bits 1))))) 57 | (2 ; only 2 digits left 58 | (setf bstream 59 | (append bstream (decimal->bstream (group->decimal v 2) 60 | (final-digit-bits 2))))) 61 | (otherwise ; at least 3 digits left 62 | (setf bstream 63 | (append bstream 64 | (decimal->bstream (group->decimal v 3) 10))))))))) 65 | 66 | ;;; :alnum mode 67 | (defun pair->decimal (values num) 68 | "alnum pairs of length NUM (1 or 2) to decimal" 69 | (declare (type list values)) 70 | (case num 71 | (1 (nth 0 values)) 72 | (2 (+ (* (nth 0 values) 45) (nth 1 values))))) 73 | 74 | (defun alnum->bstream (bytes) 75 | (declare (type list bytes)) 76 | (cl-labels ((alnum-value (byte) 77 | (byte-value :alnum byte))) 78 | (let ((values (mapcar #'alnum-value bytes)) 79 | (bstream nil)) 80 | (do ((v values (nthcdr 2 v))) 81 | ((null v) bstream) 82 | (case (length v) 83 | (1 ; only 1 alnum left 84 | (setf bstream 85 | (append bstream 86 | (decimal->bstream (pair->decimal v 1) 6)))) 87 | (otherwise ; at least 2 alnum left 88 | (setf bstream 89 | (append bstream 90 | (decimal->bstream (pair->decimal v 2) 11))))))))) 91 | 92 | ;;; :byte mode 93 | (defun byte->bstream (bytes) 94 | (declare (type list bytes)) 95 | (cl-labels ((join (prev cur) 96 | (append prev (decimal->bstream (byte-value :byte cur) 8)))) 97 | (reduce #'join bytes :initial-value nil))) 98 | 99 | ;;; :kanji mode 100 | (defun kanji->decimal (word range) 101 | (let ((subtractor (ecase range 102 | (0 #x8140) 103 | (1 #xc140)))) 104 | (decf word subtractor) 105 | (setf word (+ (* (ash word -8) #xc0) 106 | (logand word #xff))))) 107 | 108 | (defun kanji->bstream (bytes) 109 | (declare (type list bytes)) 110 | (cl-labels ((kanji-value (byte) 111 | (byte-value :kanji byte))) 112 | (let ((values (mapcar #'kanji-value bytes)) 113 | (delta 1) 114 | (bstream nil)) 115 | (do ((v values (nthcdr delta v))) 116 | ((null v) bstream) 117 | (case (length v) 118 | (1 ; only 1 byte left 119 | (setf bstream 120 | (append bstream (decimal->bstream (car v) 13))) 121 | (setf delta 1)) 122 | (otherwise ; at least 2 bytes left 123 | (multiple-value-bind (kanji-p word range) (starts-kanji-p v) 124 | (if kanji-p 125 | (progn 126 | (setf bstream 127 | (append bstream 128 | (decimal->bstream (kanji->decimal word range) 129 | 13))) 130 | (setf delta 2)) 131 | (progn 132 | (setf bstream 133 | (append bstream (decimal->bstream (car v) 13))) 134 | (setf delta 1)))))))))) 135 | 136 | ;;; :eci mode 137 | (defun eci->bstream (bytes) 138 | "TODO" 139 | (declare (ignore bytes)) 140 | (error "eci->bstream: TODO...")) 141 | 142 | (defun bstream-trans-func (mode) 143 | (case mode 144 | (:numeric #'numeric->bstream) 145 | (:alnum #'alnum->bstream) 146 | (:byte #'byte->bstream) 147 | (:kanji #'kanji->bstream))) 148 | 149 | (defun kanji-bytes-length (bytes) 150 | (declare (type list bytes)) 151 | (let ((step 1) 152 | (len 0)) 153 | (do ((b bytes (nthcdr step b))) 154 | ((null b) len) 155 | (if (starts-kanji-p b) 156 | (setf step 2) 157 | (setf step 1)) 158 | (incf len)))) 159 | 160 | (defun bytes-length (bytes mode) 161 | "number of data characters under MODE" 162 | (declare (type list bytes) (type qr-mode mode)) 163 | (case mode 164 | ((:numeric :alnum :byte) (length bytes)) 165 | (:kanji (kanji-bytes-length bytes)))) 166 | 167 | (defun segment-bstream-length (segment version) 168 | "bit stream length of SEGMENT (:mode b0 b1 ...) under VERSION" 169 | (declare (type list segment)) 170 | (let* ((mode (car segment)) 171 | (bytes (cdr segment)) 172 | (m 4) 173 | (c (char-count-bits version mode)) 174 | (d (bytes-length bytes mode)) 175 | (r 0)) 176 | ;; M = number of bits in mode indicator 177 | ;; C = number of bits in character count indicator 178 | ;; D = number of input data characters 179 | (case mode 180 | (:numeric 181 | (setf r (final-digit-bits (mod d 3))) 182 | ;; B = M + C + 10 * (D / 3) + R 183 | (+ m c (* 10 (floor d 3)) r)) 184 | (:alnum 185 | (setf r (mod d 2)) 186 | ;; B = M + C + 11 * (D / 2) + 6 * (D % 2) 187 | (+ m c (* 11 (floor d 2)) r)) 188 | (:byte 189 | ;; B = M + C + 8 * D 190 | (+ m c (* 8 d))) 191 | (:kanji 192 | ;; B = M + C + 13 * D 193 | (+ m c (* 13 d)))))) 194 | 195 | (defun segment->bstream (segment version) 196 | "SEGMENT (:mode b0 b1 ...) to bit stream under VERSION" 197 | (declare (type list segment)) 198 | (let* ((mode (car segment)) 199 | (bytes (cdr segment)) 200 | (len (bytes-length bytes mode)) 201 | (n (char-count-bits version mode)) 202 | (bstream nil)) 203 | (append bstream (mode-indicator mode) 204 | (decimal->bstream len n) ; character count indicator 205 | (funcall (bstream-trans-func mode) bytes)))) 206 | -------------------------------------------------------------------------------- /qrencode/codeword.el: -------------------------------------------------------------------------------- 1 | ;; -*- lexical-binding: t -*- 2 | 3 | ;;;; Copyright (c) 2011-2014 jnjcc, Yste.org. All rights reserved. 4 | ;;;; 5 | ;;;; bit stream to codeword conversion 6 | 7 | ;; (in-package #:cl-qrencode) 8 | 9 | (defun padding-bits (bstream) 10 | "add padding bits so that BSTREAM ends at a codeword boundary" 11 | (make-list (- 8 (mod (length bstream) 8)) 0)) 12 | 13 | (defun pad-codewords (bstream version level) 14 | "add pad codewords (after adding padding-bits) to fill data codeword capacity" 15 | (let ((pad-words '((1 1 1 0 1 1 0 0) 16 | (0 0 0 1 0 0 0 1))) 17 | (pad-len (- (data-words-capacity version level) 18 | (/ (length bstream) 8))) 19 | (ret nil)) 20 | (dotimes (i pad-len) 21 | (setf ret (append ret (nth (mod i 2) pad-words)))) 22 | ret)) 23 | 24 | (defun bstream->codewords (bstream) 25 | "convert bstream into codewords, as coefficients of the terms of a polynomial" 26 | (do ((b bstream (nthcdr 8 b)) 27 | (codewords nil)) 28 | ((null b) codewords) 29 | (setf codewords (append codewords (list (bstream->decimal b 8)))))) 30 | 31 | (defun take-in-turn (blks) 32 | "taking codewords from each block (bound by minimum length) in turn" 33 | (reduce #'append (apply #'map #'list #'list blks))) 34 | 35 | (defun take-data-in-turn (blocks blk1 data1 blk2 data2) 36 | "taking data words from each block (might have different length) in turn" 37 | (let ((data-final nil) 38 | (left-blks nil)) 39 | (setf data-final (take-in-turn blocks)) 40 | (cond 41 | ((or (= blk1 0) (= blk2 0)) 42 | ;; only one kind of block exists 43 | (setf left-blks nil)) 44 | ((> data1 data2) 45 | ;; block 1 has more elements left 46 | (setf left-blks (mapcar #'(lambda (blk) 47 | (nthcdr data2 blk)) 48 | (subseq blocks 0 blk1)))) 49 | ((> data2 data1) 50 | ;; block 2 has more elements left 51 | (setf left-blks (mapcar #'(lambda (blk) 52 | (nthcdr data1 blk)) 53 | (subseq blocks blk1 (+ blk1 blk2)))))) 54 | (if left-blks 55 | (append data-final (take-in-turn left-blks)) 56 | data-final))) 57 | -------------------------------------------------------------------------------- /qrencode/encode.el: -------------------------------------------------------------------------------- 1 | ;; -*- lexical-binding: t -*- 2 | 3 | ;;;; Copyright (c) 2011-2014 jnjcc, Yste.org. All rights reserved. 4 | ;;;; 5 | ;;;; final QR code symbol 6 | 7 | ;; (in-package #:cl-qrencode) 8 | 9 | (require 'cl) 10 | (require 'eieio) 11 | 12 | (defclass qr-symbol () 13 | ((matrix :initform nil :initarg :matrix :reader matrix 14 | :documentation "qr code symbol as matrix") 15 | (modules :initform nil :initarg :modules :reader modules 16 | :documentation "qr code symbol modules"))) 17 | 18 | ;; (defmethod print-object ((symbol qr-symbol) stream) 19 | ;; (fresh-line stream) 20 | ;; (with-slots (matrix modules) symbol 21 | ;; (format stream "qr symbol ~A x ~A:~%" modules modules) 22 | ;; (dotimes (i modules) 23 | ;; (dotimes (j modules) 24 | ;; (if (dark-module-p matrix i j) 25 | ;; (format stream "1 ") 26 | ;; (format stream "0 "))) 27 | ;; (format stream "~%")))) 28 | 29 | ;;; FIXME: other encodings??? 30 | (defun ascii->bytes (text) 31 | (map 'list #'identity text)) 32 | 33 | (defun bytes->input (bytes version level mode) 34 | (setf version (min (max version 1) 40)) 35 | (let ((input (make-instance 'qr-input :bytes bytes :qrversion version 36 | :ec-level level :mode mode))) 37 | (data-encoding input) 38 | (ec-coding input) 39 | (structure-message input) 40 | (module-placement input) 41 | input)) 42 | 43 | (defun input->symbol (input) 44 | "encode qr symbol from a qr-input" 45 | (multiple-value-bind (matrix mask-ref) 46 | (data-masking input) 47 | (declare (ignore mask-ref)) 48 | (let ((modules (matrix-modules (qrversion input)))) 49 | (make-instance 'qr-symbol :matrix matrix :modules modules)))) 50 | 51 | (defun encode-symbol-bytes (bytes version level mode) 52 | "encode final qr symbol from BYTES list" 53 | (when (null version) (setf version 1)) 54 | (when (null level) (setf level :level-m)) 55 | (let ((input (bytes->input bytes version level mode))) 56 | (dbg :dbg-input "version: ~A; segments: ~A~%" (qrversion input) 57 | (segments input)) 58 | (input->symbol input))) 59 | 60 | ;;;----------------------------------------------------------------------------- 61 | ;;; One Ring to Rule Them All, One Ring to Find Them, 62 | ;;; One Ring to Bring Them All and In the Darkness Blind Them: 63 | ;;; This function wraps all we need. 64 | ;;;----------------------------------------------------------------------------- 65 | ;; (sdebug :dbg-input) 66 | (defun encode-symbol (text version level mode) 67 | "encode final qr symbol, unless you know what you are doing, leave MODE NIL" 68 | (when (null version) (setf version 1)) 69 | (when (null level) (setf level :level-m)) 70 | (let ((bytes (ascii->bytes text))) 71 | (encode-symbol-bytes bytes version level mode))) 72 | -------------------------------------------------------------------------------- /qrencode/input.el: -------------------------------------------------------------------------------- 1 | ;; -*- lexical-binding: t -*- 2 | 3 | ;;;; Copyright (c) 2011-2014 jnjcc, Yste.org. All rights reserved. 4 | ;;;; 5 | 6 | ;; (in-package #:cl-qrencode) 7 | (require 'cl) 8 | (require 'eieio) 9 | 10 | (defclass qr-input () 11 | ((bytes 12 | :initform nil :initarg :bytes :reader bytes ;; :type list 13 | :documentation "list of bytes to be encoded") 14 | (qrversion 15 | :initform 1 :initarg :qrversion :reader qrversion 16 | :documentation "version of qr symbol, adapted according to BYTES") 17 | (ec-level ; cannot be NIL 18 | :initform :level-m :initarg :ec-level :reader level) 19 | (mode 20 | :initform nil :initarg :mode :reader mode ;; :type (or nil qr-mode) 21 | :documentation "if supplied, we force all BYTES to be under MODE, 22 | therefore, unless you know exactly what you are doing, leave this NIL") 23 | (cur-byte 24 | :initform 0 :accessor cur-byte 25 | :documentation "index of BYTES during data analysis") 26 | (segments 27 | :initform nil :accessor segments ;; :type list 28 | :documentation 29 | "list of list, of the form ((:mode1 byte ...) (:mode2 byte ...) ...)") 30 | (bstream 31 | :initform nil :reader bstream ;; :type list 32 | :documentation "list of 0-1 values after encoding SEGMENTS") 33 | (blocks 34 | :initform nil :reader blocks ;; :type list 35 | :documentation "list of list, of the form ((codeword ...) (codeword ...) ...) 36 | after converting BSTREAM to codewords") 37 | (ecc-blocks ; error correction blocks 38 | :initform nil :reader ecc-blocks ;; :type list 39 | :documentation "list of list, ec codewords corresponding to BLOCKS") 40 | (msg-codewords 41 | :initform nil :reader qrmessage ;; :type list 42 | :documentation "list of codewords from BLOCKS & ECC-BLOCKS, 43 | interleaving if neccessary") 44 | (matrix 45 | :initform nil :accessor matrix 46 | :documentation "raw QR code symbol (without masking) as matrix"))) 47 | 48 | (defmethod initialize-instance :after ((input qr-input) &rest args) 49 | (declare (ignore args)) 50 | (validate-and-analysis input)) 51 | 52 | ;;; 0) Data analysis 53 | (defgeneric validate-and-analysis (input) 54 | "adapt VERSION according to BYTES, and fill SEGMENTS slot") 55 | ;;; 1) Data encoding 56 | (defgeneric data-encoding (input) 57 | "encode SEGMENTS into BSTREAM slot") 58 | ;;; 2) Error correction coding 59 | (defgeneric ec-coding (input) 60 | "split BSTREAM into BLOCKS, do rs-ecc, and fill ECC-BLOCKS") 61 | ;;; 3) Structure final message 62 | (defgeneric structure-message (input) 63 | "interleaving BLOCKS and ECC-BLOCKS into MSG-CODEWORDS") 64 | ;;; 4) Codeword placement in matrix, a.k.a, raw QR code symbol 65 | (defgeneric module-placement (input) 66 | "write MSG-CODEWORDS into the raw (without masking) MATRIX") 67 | ;;; 5) Data masking & Format information 68 | (defgeneric data-masking (input) 69 | "mask MATRIX with best pattern, generate the final symbol") 70 | 71 | (defgeneric data-analysis (input) 72 | "BYTES -> SEGMETS, switch bewteen modes as necessary to 73 | achieve the most efficient conversion of data") 74 | (defgeneric redo-data-analysis (input) 75 | "VERSION changed, reset CUR-BYTE and redo data analysis") 76 | (defgeneric analyse-byte-mode (input &optional seg)) 77 | (defgeneric analyse-alnum-mode (input &optional seg)) 78 | (defgeneric analyse-numeric-mode (input &optional seg)) 79 | (defgeneric analyse-kanji-mode (input &optional seg)) 80 | (defgeneric append-cur-byte (input &optional seg) 81 | "append CUR-BYTE of BYTES into SEGMENTS") 82 | (defun mode-analyse-func (mode) 83 | "put CUR-BYTE into MODE, and then look at following BYTES for new segment" 84 | (case mode 85 | (:byte #'analyse-byte-mode) 86 | (:alnum #'analyse-alnum-mode) 87 | (:numeric #'analyse-numeric-mode) 88 | (:kanji #'analyse-kanji-mode))) 89 | 90 | (defmethod data-analysis ((input qr-input)) 91 | (block data-analysis-block 92 | (with-slots (mode cur-byte segments) input 93 | (when mode ; MODE supplied 94 | (let ((seg (append (list mode) (bytes input)))) 95 | (setf cur-byte (length (bytes input))) 96 | (setf segments (append segments (list seg)))) 97 | (return-from data-analysis-block))) 98 | (with-slots (bytes qrversion segments) input 99 | (let ((init-mode (select-init-mode bytes qrversion))) 100 | (funcall (mode-analyse-func init-mode) input))))) 101 | 102 | (defmethod redo-data-analysis ((input qr-input)) 103 | (with-slots (cur-byte segments) input 104 | (setf cur-byte 0) 105 | (setf segments nil) 106 | (data-analysis input))) 107 | 108 | (defun select-init-mode (bytes version) 109 | "optimization of bitstream length: select initial mode" 110 | ;;(declare (type list bytes)) 111 | (let ((init-xor (xor-subset-of bytes))) 112 | (case init-xor 113 | (:byte :byte) 114 | (:kanji 115 | (case (xor-subset-of (nthcdr 2 bytes)) 116 | ((:numeric :alnum) :kanji) 117 | (:byte 118 | (let ((nunits (ecase (version-range version) 119 | ((0 1) 5) 120 | (2 6)))) 121 | (if (every-unit-matches (nthcdr 3 bytes) 2 nunits :kanji) 122 | :byte 123 | :kanji))) 124 | (otherwise :kanji))) 125 | (:alnum 126 | (let ((nunits (ecase (version-range version) 127 | (0 6) (1 7) (2 8)))) 128 | ;; number of units (characters) match :alnum, followed by a :byte unit 129 | (multiple-value-bind (n last-mode) (nunits-matches (cdr bytes) :alnum) 130 | (if (and (< n nunits) (eq last-mode :byte)) 131 | :byte 132 | :alnum)))) 133 | (:numeric 134 | (let ((nbunits (ecase (version-range version) 135 | ((0 1) 4) (2 5))) 136 | (naunits (ecase (version-range version) 137 | (0 7) (1 8) (2 9)))) 138 | (multiple-value-bind (n last-mode) (nunits-matches (cdr bytes) :numeric) 139 | (if (and (< n nbunits) (eq last-mode :byte)) 140 | :byte 141 | (if (and (< n naunits) (eq last-mode :alnum)) 142 | :alnum 143 | :numeric)))))))) 144 | 145 | ;;; UNIT: character under a certain mode, 146 | ;;; a byte under :numeric :alnum & :byte, or a byte-pair under :kanji 147 | (defun every-unit-matches (bytes usize nunits mode) 148 | "if every unit of USZIE bytes (at most NUNITS unit) within BYTES matches MODE" 149 | ;; (declare (type list bytes) (type qr-mode mode)) 150 | (block every-unit-matches-block 151 | (when (>= (length bytes) (* usize nunits)) 152 | (dotimes (i nunits) 153 | (let ((b (nthcdr (* usize i) bytes))) 154 | (unless (eq (xor-subset-of b) mode) 155 | (return-from every-unit-matches-block nil)))) 156 | (return-from every-unit-matches-block t)))) 157 | 158 | (defun nunits-matches (bytes mode) 159 | "(number of units that matches MODE, and mode for the first unmatched unit)" 160 | ;; (declare (type list bytes) (type qr-mode mode)) 161 | (let ((usize (ecase mode 162 | ((:byte :alnum :numeric) 1) 163 | ;; as for :kanji, 2 bytes forms a single unit 164 | (:kanji 2))) 165 | (nunits 0)) 166 | (do ((b bytes (nthcdr usize b))) 167 | ((or (null b) 168 | (not (eq (xor-subset-of b) mode))) 169 | (values nunits (xor-subset-of b))) 170 | (incf nunits)))) 171 | 172 | (defmethod analyse-byte-mode ((input qr-input) &optional seg) 173 | ;; (declare (type list seg)) 174 | (block analyse-byte-mode-block 175 | (when (null seg) 176 | (setf seg '(:byte))) 177 | (setf seg (append-cur-byte input seg)) 178 | (unless seg 179 | (return-from analyse-byte-mode-block)) 180 | (with-slots (bytes cur-byte qrversion segments) input 181 | (let* ((range (version-range qrversion)) 182 | (nkunits (ecase range ; number of :kanji units before more :byte 183 | (0 9) (1 12) (2 13))) 184 | (nanuits (ecase range ; number of :alnum units before more :byte 185 | (0 11) (1 15) (2 16))) 186 | (nmunits1 (ecase range ; number of :numeric units before more :byte 187 | (0 6) (1 8) (2 9))) 188 | (nmunits2 (ecase range ; number of :numeric units before more :alnum 189 | (0 6) (1 7) (2 8))) 190 | (switch-mode nil)) 191 | (multiple-value-bind (nmatches last-mode) 192 | (nunits-matches (nthcdr cur-byte bytes) :kanji) 193 | (and (>= nmatches nkunits) (eq last-mode :byte) 194 | (setf switch-mode :kanji))) 195 | (unless switch-mode 196 | (multiple-value-bind (nmatches last-mode) 197 | (nunits-matches (nthcdr cur-byte bytes) :alnum) 198 | (and (>= nmatches nanuits) (eq last-mode :byte) 199 | (setf switch-mode :alnum)))) 200 | (unless switch-mode 201 | (multiple-value-bind (nmatches last-mode) 202 | (nunits-matches (nthcdr cur-byte bytes) :numeric) 203 | (case last-mode 204 | (:byte (and (>= nmatches nmunits1) 205 | (setf switch-mode :numeric))) 206 | (:alnum (and (>= nmatches nmunits2) 207 | (setf switch-mode :numeric)))))) 208 | (if switch-mode 209 | (progn 210 | ;; current segment finished, add a new SWITCH-MODE segment 211 | (setf segments (append segments (list seg))) 212 | (setf seg (list switch-mode))) 213 | (setf switch-mode :byte)) 214 | (funcall (mode-analyse-func switch-mode) input seg))))) 215 | 216 | (defmethod analyse-alnum-mode (input &optional seg) 217 | (block analyse-alnum-mode-block 218 | (when (null seg) 219 | (setf seg '(:alnum))) 220 | (setf seg (append-cur-byte input seg)) 221 | (unless seg 222 | (return-from analyse-alnum-mode-block)) 223 | (with-slots (bytes cur-byte qrversion segments) input 224 | (let ((nmunits (ecase (version-range qrversion) 225 | (0 13) (1 15) (2 17))) 226 | (switch-mode nil)) 227 | (when (>= (car (nunits-matches (nthcdr cur-byte bytes) :kanji)) 1) 228 | (setf switch-mode :kanji)) 229 | (unless switch-mode 230 | (when (>= (car (nunits-matches (nthcdr cur-byte bytes) :byte)) 1) 231 | (setf switch-mode :byte))) 232 | (unless switch-mode 233 | (multiple-value-bind (nmatches last-mode) 234 | (nunits-matches (nthcdr cur-byte bytes) :numeric) 235 | (and (>= nmatches nmunits) (eq last-mode :alnum) 236 | (setf switch-mode :numeric)))) 237 | (if switch-mode 238 | (progn 239 | (setf segments (append segments (list seg))) 240 | (setf seg (list switch-mode))) 241 | (setf switch-mode :alnum)) 242 | (funcall (mode-analyse-func switch-mode) input seg))))) 243 | 244 | (defmethod analyse-numeric-mode (input &optional seg) 245 | ;; (declare (type list seg)) 246 | (block analyse-numeric-mode-block 247 | (when (null seg) 248 | (setf seg '(:numeric))) 249 | (setf seg (append-cur-byte input seg)) 250 | (unless seg 251 | (return-from analyse-numeric-mode-block)) 252 | (with-slots (bytes cur-byte qrversion segments) input 253 | (let ((switch-mode nil)) 254 | (when (>= (car (nunits-matches (nthcdr cur-byte bytes) :kanji)) 1) 255 | (setf switch-mode :kanji)) 256 | (unless switch-mode 257 | (when (>= (car (nunits-matches (nthcdr cur-byte bytes) :byte)) 1) 258 | (setf switch-mode :byte))) 259 | (unless switch-mode 260 | (when (>= (car (nunits-matches (nthcdr cur-byte bytes) :alnum)) 1) 261 | (setf switch-mode :alnum))) 262 | (if switch-mode 263 | (progn 264 | (setf segments (append segments (list seg))) 265 | (setf seg (list switch-mode))) 266 | (setf switch-mode :numeric)) 267 | (funcall (mode-analyse-func switch-mode) input seg))))) 268 | 269 | (defmethod append-cur-byte ((input qr-input) &optional seg) 270 | "if CUR-BYTE is the last byte, return nil" 271 | ;;(declare (type list seg)) 272 | (block append-cur-byte-block 273 | (with-slots (bytes cur-byte segments) input 274 | (setf seg (append seg (list (nth cur-byte bytes)))) 275 | (incf cur-byte) 276 | (when (>= cur-byte (length bytes)) 277 | (setf segments (append segments (list seg))) 278 | (setf seg nil)) 279 | (return-from append-cur-byte-block seg)))) 280 | 281 | (defmethod analyse-kanji-mode (input &optional seg) 282 | (when (null seg) 283 | (setf seg '(:byte))) 284 | (with-slots (bytes cur-byte segments) input 285 | (setf seg (append seg (nthcdr cur-byte bytes))) 286 | (setf cur-byte (length bytes)) 287 | (setf segments (append segments (list seg))))) 288 | 289 | (defmethod validate-and-analysis ((input qr-input)) 290 | (with-slots ((level ec-level) segments) input 291 | (unless (<= 1 (qrversion input) 40) 292 | (error "version %s out of bounds" (qrversion input))) 293 | (do ((prev -1)) 294 | ((<= (qrversion input) prev)) 295 | (setf prev (qrversion input)) 296 | (redo-data-analysis input) 297 | (cl-labels ((seg-bstream-len (seg) 298 | (segment-bstream-length seg (qrversion input)))) 299 | (let* ((blen (reduce #'+ (mapcar #'seg-bstream-len segments) 300 | :initial-value 0)) 301 | (min-v (minimum-version prev (ceiling blen 8) level))) 302 | (if min-v 303 | (setf (slot-value input 'qrversion) min-v) 304 | (error "no version to hold %s bytes" (ceiling blen 8)))))))) 305 | 306 | (defmethod data-encoding ((input qr-input)) 307 | (with-slots (qrversion (level ec-level) segments) input 308 | (cl-labels ((seg->bstream (seg) 309 | (segment->bstream seg qrversion))) 310 | (let* ((bs (reduce #'append (mapcar #'seg->bstream segments) 311 | :initial-value nil)) 312 | (tt (terminator bs qrversion level)) 313 | ;; connect bit streams in all segment, with terminator appended 314 | (bstream (append bs tt))) 315 | ;; add padding bits 316 | (setf bstream (append bstream (padding-bits bstream))) 317 | ;; add pad codewords, finishes data encoding 318 | (setf (slot-value input 'bstream) 319 | (append bstream 320 | (pad-codewords bstream qrversion level))))))) 321 | 322 | (defmethod ec-coding ((input qr-input)) 323 | (with-slots (qrversion (level ec-level) bstream) input 324 | (let ((codewords (bstream->codewords bstream)) 325 | (blocks nil) 326 | (ecc-blocks nil) 327 | ;; RS error correction obj for blk1 & blk2 328 | (rs1 nil) 329 | (rs2 nil)) 330 | (multiple-value-bind (ecc-num blk1 data1 blk2 data2) 331 | (ecc-block-nums qrversion level) 332 | (when (> blk1 0) 333 | (setf rs1 (make-instance 'rs-ecc :k data1 :ec ecc-num))) 334 | (when (> blk2 0) 335 | (setf rs2 (make-instance 'rs-ecc :k data2 :ec ecc-num))) 336 | (dotimes (i blk1) 337 | (setf blocks 338 | (append blocks (list (subseq codewords 0 data1)))) 339 | (setf codewords (nthcdr data1 codewords))) 340 | (dotimes (i blk2) 341 | (setf blocks 342 | (append blocks (list (subseq codewords 0 data2)))) 343 | (setf codewords (nthcdr data2 codewords))) 344 | (dotimes (i blk1) 345 | (setf ecc-blocks 346 | (append ecc-blocks (list (ecc-poly rs1 (nth i blocks)))))) 347 | (dotimes (i blk2) 348 | (setf ecc-blocks 349 | (append ecc-blocks (list (ecc-poly rs2 (nth (+ i blk1) blocks)))))) 350 | (setf (slot-value input 'blocks) blocks) 351 | (setf (slot-value input 'ecc-blocks) ecc-blocks))))) 352 | 353 | (defmethod structure-message ((input qr-input)) 354 | (with-slots (qrversion (level ec-level) blocks ecc-blocks) input 355 | (let ((final nil)) 356 | (multiple-value-bind (ecc-num blk1 data1 blk2 data2) 357 | (ecc-block-nums qrversion level) 358 | (declare (ignore ecc-num)) 359 | (setf (slot-value input 'msg-codewords) 360 | (append final 361 | ;; interleave data blocks, data blocks may differ in length 362 | (take-data-in-turn blocks blk1 data1 blk2 data2) 363 | ;; we know error correction blocks are of the same length 364 | (take-in-turn ecc-blocks))))))) 365 | 366 | (defmethod module-placement ((input qr-input)) 367 | (setf (matrix input) (make-matrix (qrversion input) nil)) 368 | (with-slots (qrversion msg-codewords matrix) input 369 | ;; Function pattern placement 370 | (function-patterns matrix qrversion) 371 | ;; Symbol character placement 372 | (let ((rbits (remainder-bits qrversion)) 373 | (bstream nil)) 374 | (cl-labels ((dec->byte (codeword) 375 | (decimal->bstream codeword 8))) 376 | (setf bstream (append (reduce #'append (mapcar #'dec->byte msg-codewords)) 377 | ;; data capacity of _symbol_ does not divide by 8 378 | (make-list rbits 0)))) 379 | (symbol-character bstream matrix qrversion)))) 380 | 381 | (defmethod data-masking ((input qr-input)) 382 | "(masked matrix, mask pattern reference)" 383 | (with-slots (qrversion (level ec-level) matrix) input 384 | (let ((modules (matrix-modules qrversion))) 385 | (multiple-value-bind (masked indicator) 386 | (choose-masking matrix modules level) 387 | (values masked (mask-pattern-ref indicator)))))) 388 | -------------------------------------------------------------------------------- /qrencode/mask.el: -------------------------------------------------------------------------------- 1 | ;; -*- lexical-binding: t -*- 2 | 3 | ;;;; Copyright (c) 2011-2014 jnjcc, Yste.org. All rights reserved. 4 | ;;;; 5 | ;;;; Data masking 6 | 7 | ;;(in-package #:cl-qrencode) 8 | (require 'cl) 9 | 10 | ;;; only encoding region modules (excluding format information) are masked 11 | (defun encoding-module-p (matrix i j) 12 | "modules belong to encoding region, excluding format & version information" 13 | (or (eq (aref (aref matrix i) j) :light) 14 | (eq (aref (aref matrix i) j) :dark))) 15 | (defun non-mask-module-p (matrix i j) 16 | (not (encoding-module-p matrix i j))) 17 | (defun reverse-module-color (matrix i j) 18 | (case (aref (aref matrix i) j) 19 | (:dark :light) (:light :dark))) 20 | 21 | ;;; all modules are evaluated: 22 | ;;; there should be only :dark :light :fdark :flight modules left by now 23 | (defun dark-module-p (matrix i j) 24 | (or (eq (aref (aref matrix i) j) :fdark) 25 | (eq (aref (aref matrix i) j) :dark))) 26 | 27 | (defun copy-and-mask (matrix modules level mask-ind) 28 | "make a new matrix and mask using MASK-IND for later evaluation" 29 | (let ((ret (make-modules-matrix modules nil)) 30 | (mask-p (mask-condition mask-ind)) 31 | (darks 0)) 32 | (dotimes (i modules) 33 | (dotimes (j modules) 34 | (cond 35 | ((non-mask-module-p matrix i j) 36 | (setf (aref (aref ret i) j) (aref (aref matrix i) j))) 37 | ((funcall mask-p i j) ; need mask 38 | (setf (aref (aref ret i) j) (reverse-module-color matrix i j))) 39 | (t 40 | (setf (aref (aref ret i) j) (aref (aref matrix i) j)))) 41 | (when (dark-module-p ret i j) 42 | (incf darks)))) 43 | (multiple-value-bind (dummy fi-darks) 44 | (format-information ret modules level mask-ind) 45 | (declare (ignore dummy)) 46 | ;; add format information dark modules 47 | (values ret (+ darks fi-darks))))) 48 | 49 | (defun mask-matrix (matrix modules level mask-ind) 50 | "do not evaluate, just go ahead and mask MATRIX using MASK-IND mask pattern" 51 | (let ((mask-p (mask-condition mask-ind))) 52 | (dotimes (i modules) 53 | (dotimes (j modules) 54 | (and (encoding-module-p matrix i j) 55 | (funcall mask-p i j) 56 | (setf (aref (aref matrix i) j) (reverse-module-color matrix i j))))) 57 | ;; paint format information 58 | (format-information matrix modules level mask-ind) 59 | matrix)) 60 | 61 | (defun choose-masking (matrix modules level) 62 | "mask and evaluate using each mask pattern, choose the best mask result" 63 | (let ((n4 10) 64 | (best-matrix nil) 65 | (mask-indicator nil) 66 | (min-penalty nil) 67 | (square (* modules modules)) 68 | (cur-penalty 0)) 69 | (dotimes (i *mask-pattern-num*) 70 | (multiple-value-bind (cur-matrix darks) 71 | (copy-and-mask matrix modules level i) 72 | ;; feature 4: proportion of dark modules in entire symbol 73 | (let ((bratio (/ (+ (* darks 200) square) square 2))) 74 | (setf cur-penalty (* (/ (abs (- bratio 50)) 5) n4))) 75 | (incf cur-penalty (evaluate-feature-123 cur-matrix modules)) 76 | (when (or (null min-penalty) 77 | (< cur-penalty min-penalty)) 78 | (setf min-penalty cur-penalty 79 | mask-indicator i 80 | best-matrix cur-matrix)))) 81 | (values best-matrix mask-indicator))) 82 | 83 | ;;; feature 1 & 2 & 3 84 | (defun evaluate-feature-123 (matrix modules) 85 | (let ((penalty 0)) 86 | (incf penalty (evaluate-feature-2 matrix modules)) 87 | (dotimes (col modules) 88 | (let ((rlength (calc-run-length matrix modules col :row))) 89 | (incf penalty (evaluate-feature-1 rlength)) 90 | (incf penalty (evaluate-feature-3 rlength)))) 91 | (dotimes (row modules) 92 | (let ((rlength (calc-run-length matrix modules row :col))) 93 | (incf penalty (evaluate-feature-1 rlength)) 94 | (incf penalty (evaluate-feature-3 rlength)))) 95 | penalty)) 96 | 97 | (defun calc-run-length (matrix modules num direction) 98 | "list of number of adjacent modules in same color" 99 | (when (null direction) (setf direction :row)) 100 | (let ((rlength nil) 101 | (ridx 0)) 102 | (cl-labels ((get-elem (idx) 103 | (case direction 104 | (:row (aref (aref matrix num) idx)) 105 | (:col (aref (aref matrix idx) num)))) 106 | (add-to-list (list elem) 107 | (append list (list elem)))) 108 | ;; we make sure (NTH 1 rlength) is for dark module 109 | (when (same-color-p (get-elem 0) :dark) 110 | (setf rlength (add-to-list rlength -1) 111 | ridx 1)) 112 | (setf rlength (add-to-list rlength 1)) 113 | 114 | (loop for i from 1 to (- modules 1) do 115 | (if (same-color-p (get-elem i) (get-elem (- i 1))) 116 | (incf (nth ridx rlength)) 117 | (progn 118 | (incf ridx) 119 | (setf rlength (add-to-list rlength 1))))) 120 | rlength))) 121 | 122 | (defun evaluate-feature-1 (rlength) 123 | "(5 + i) adjacent modules in row/column in same color. (N1 + i) points, N1 = 3" 124 | (let ((n1 3) 125 | (penalty 0)) 126 | (dolist (sz rlength penalty) 127 | (when (> sz 5) 128 | (incf penalty (+ n1 sz -5)))))) 129 | 130 | (defun evaluate-feature-3 (rlength) 131 | "1:1:3:1:1 ration (dark:light:dark:light:dark) pattern in row/column, 132 | preceded or followed by light area 4 modules wide. N3 points, N3 = 40" 133 | (let ((n3 40) 134 | (len (length rlength)) 135 | (penalty 0)) 136 | (do ((i 3 (+ i 2))) 137 | ((>= i (- len 2)) penalty) 138 | (when (and (= (mod i 2) 1) ; for dark module 139 | (= (mod (nth i rlength) 3) 0) 140 | (let ((fact (floor (nth i rlength) 3))) 141 | ;; 1:1:3:1:1 142 | (when (= fact 143 | (nth (- i 2) rlength) 144 | (nth (- i 1) rlength) 145 | (nth (+ i 1) rlength) 146 | (nth (+ i 2) rlength)) 147 | (cond 148 | ((<= (- i 3) 0) (incf penalty n3)) 149 | ((>= (+ i 4) len) (incf penalty n3)) 150 | ((>= (nth (- i 3) rlength) (* 4 fact)) (incf penalty n3)) 151 | ((>= (nth (+ i 3) rlength) (* 4 fact)) (incf penalty n3)))))))))) 152 | 153 | (defun evaluate-feature-2 (matrix modules) 154 | "block m * n of modules in same color. N2 * (m-1) * (n-1) points, N2=3" 155 | (let ((n2 3) 156 | (penalty 0) 157 | (bcount 0)) 158 | (dotimes (i (- modules 1) penalty) 159 | (dotimes (j (- modules 1)) 160 | (when (dark-module-p matrix i j) 161 | (incf bcount)) 162 | (when (dark-module-p matrix (+ i 1) j) 163 | (incf bcount)) 164 | (when (dark-module-p matrix i (+ j 1)) 165 | (incf bcount)) 166 | (when (dark-module-p matrix (+ i 1) (+ j 1)) 167 | (incf bcount)) 168 | (when (or (= bcount 0) (= bcount 4)) 169 | (incf penalty n2)))))) 170 | -------------------------------------------------------------------------------- /qrencode/matrix.el: -------------------------------------------------------------------------------- 1 | ;; -*- lexical-binding: t -*- 2 | 3 | ;;;; Copyright (c) 2011-2014 jnjcc, Yste.org. All rights reserved. 4 | ;;;; 5 | ;;;; Codeword placement in matrix 6 | 7 | ;;(in-package #:cl-qrencode) 8 | 9 | (require 'cl) 10 | 11 | (deftype module-color () 12 | ":RAW, nothing has been done to this module; :RESERVE, format info reserve module 13 | :FLIGHT/:FDARK, function pattern light/dark module; :LIGHT/:DARK, data modules" 14 | '(member :raw :flight :fdark :reserve :light :dark)) 15 | 16 | (defun same-color-p (color1 color2) 17 | "during QR symbol evaluation, :fdark & :dark are considered to be same" 18 | (case color1 19 | ((:flight :light) (or (eq color2 :flight) (eq color2 :light))) 20 | ((:fdark :dark) (or (eq color2 :fdark) (eq color2 :fdark))) 21 | (otherwise (eq color1 color2)))) 22 | 23 | (defun raw-module-p (matrix i j) 24 | "nothing has been done to MATRIX[I, J]" 25 | (eq (aref (aref matrix i) j) :raw)) 26 | 27 | (defun make-array (rows cols elem) 28 | (let ((v (make-vector rows nil))) 29 | (loop for i from 0 to (1- (length v)) do 30 | (setf (aref v i) (make-vector cols elem))) 31 | v)) 32 | 33 | (defun make-modules-matrix (modules init) 34 | "make a raw matrix with MODULES * MODULES elements" 35 | (when (null init) (setf init :raw)) 36 | (make-array modules modules init)) 37 | 38 | (defun make-matrix (version init) 39 | "make a raw matrix according to VERSION" 40 | (when (null init) (setf init :raw)) 41 | (let ((n (matrix-modules version))) 42 | (make-modules-matrix n init))) 43 | 44 | (defun paint-square (matrix x y n color) 45 | "Paint a square of size N*N starting from upleft (X, Y) in MATRIX to COLOR" 46 | (when (null color) (setf color :fdark)) 47 | (let ((maxx (+ x n -1)) 48 | (maxy (+ y n -1))) 49 | (loop for i from x to maxx do 50 | (loop for j from y to maxy do 51 | (setf (aref (aref matrix i) j) color)))) 52 | matrix) 53 | 54 | ;;; Function Patterns 55 | (defun function-patterns (matrix version) 56 | (let ((modules (matrix-modules version))) 57 | (finder-patterns matrix modules) 58 | (separator matrix modules) 59 | (timing-patterns matrix modules) 60 | (alignment-patterns matrix version)) 61 | matrix) 62 | ;; a) Finder Patterns: fixed position in matrix 63 | (defun one-finder-pattern (matrix x y) 64 | "Paint one finder pattern starting from upleft (X, Y)" 65 | (paint-square matrix x y 7 :fdark) 66 | (paint-square matrix (+ x 1) (+ y 1) 5 :flight) 67 | (paint-square matrix (+ x 2) (+ y 2) 3 :fdark)) 68 | (defun finder-patterns (matrix modules) 69 | ;; top-left finder pattern 70 | (one-finder-pattern matrix 0 0) 71 | ;; top-right finder pattern 72 | (one-finder-pattern matrix (- modules 7) 0) 73 | ;; bottom-left finder pattern 74 | (one-finder-pattern matrix 0 (- modules 7))) 75 | 76 | ;; b) Separator: fixed position in matrix 77 | (defun separator (matrix modules) 78 | (dotimes (j 8) 79 | ;; top-left horizontal separator 80 | (setf (aref (aref matrix 7) j) :flight) 81 | ;; top-right horizontal separator 82 | (setf (aref (aref matrix 7) (- modules j 1)) :flight) 83 | ;; bottom-left horizontal separator 84 | (setf (aref (aref matrix (- modules 8)) j) :flight)) 85 | (dotimes (i 8) 86 | ;; top-left vertical separator 87 | (setf (aref (aref matrix i) 7) :flight) 88 | ;; bottom-left vertical separator 89 | (setf (aref (aref matrix (- modules i 1)) 7) :flight) 90 | ;; top-right vertical separator 91 | (setf (aref (aref matrix i) (- modules 8)) :flight)) 92 | matrix) 93 | 94 | ;; c) Timing patterns 95 | (defun timing-patterns (matrix modules) 96 | (let ((color :fdark)) 97 | (loop for idx from 8 to (- modules 9) do 98 | (if (evenp idx) 99 | (setf color :fdark) 100 | (setf color :flight)) 101 | ;; Horizontal 102 | (setf (aref (aref matrix 6) idx) color) 103 | ;; Vertical 104 | (setf (aref (aref matrix idx) 6) color))) 105 | matrix) 106 | 107 | ;; d) Alignment Patterns: varies between versions 108 | ;; may overlap timing patterns, modules coincide with that of timing patterns 109 | (defun one-align-pattern (matrix x y) 110 | "Paint one alignment pattern centered at (X, Y)" 111 | (paint-square matrix (- x 2) (- y 2) 5 :fdark) 112 | (paint-square matrix (- x 1) (- y 1) 3 :flight) 113 | (paint-square matrix x y 1 :fdark)) 114 | (defun alignment-patterns (matrix version) 115 | (dolist (center (align-centers version) matrix) 116 | (one-align-pattern matrix (first center) (second center)))) 117 | 118 | ;;; Encoding Region 119 | (defun symbol-character (bstream matrix version) 120 | (let ((modules (matrix-modules version))) 121 | (reserve-information matrix version) 122 | (bstream-placement bstream matrix modules)) 123 | matrix) 124 | ;; reserve format information & version information 125 | (defun reserve-information (matrix version) 126 | (let ((modules (matrix-modules version))) 127 | ;; format information... 128 | ;; top-left & top-right horizontal 129 | (dotimes (j 8) 130 | (when (raw-module-p matrix 8 j) 131 | (setf (aref (aref matrix 8) j) :reserve)) 132 | (setf (aref (aref matrix 8) (- modules j 1)) :reserve)) 133 | (setf (aref (aref matrix 8) 8) :reserve) 134 | ;; top-left & bottom-left vertical 135 | (dotimes (i 8) 136 | (when (raw-module-p matrix i 8) 137 | (setf (aref (aref matrix i) 8) :reserve)) 138 | (setf (aref (aref matrix (- modules i 1)) 8) :reserve)) 139 | ;; dark module... 140 | (setf (aref (aref matrix (- modules 8)) 8) :fdark) 141 | 142 | ;; version information for version 7-40 143 | (when (>= version 7) 144 | (version-information matrix modules version)))) 145 | 146 | (defun paint-fcolor-bit (matrix i j bit) 147 | "Paint function pattern color for MATRIX[I, J] according to BIT of {0, 1}" 148 | (setf (aref (aref matrix i) j) (case bit 149 | (0 :flight) (1 :fdark)))) 150 | (defun version-information (matrix modules version) 151 | "version information placement on two blocks of modules: 152 | bottom-left 3*6 block: [modules-11, modules-9] * [0, 5] 153 | top-right 6*3 block: [0, 5] * [modules-11, modules-9]" 154 | (assert (>= version 7)) 155 | (let ((vib (version-ecc version)) 156 | (i (- modules 9)) 157 | (start (- modules 9)) 158 | (bound (- modules 11)) 159 | (j 5)) 160 | (dolist (bit vib matrix) 161 | (paint-fcolor-bit matrix i j bit) 162 | (paint-fcolor-bit matrix j i bit) 163 | (if (>= (- i 1) bound) 164 | (decf i) 165 | (progn 166 | (decf j) 167 | (setf i start)))))) 168 | 169 | ;; Symbol character placement 170 | (defun paint-color-bit (matrix i j bit) 171 | "Paint data color for MATRIX[I, J] according to BIT of {0, 1}" 172 | (setf (aref (aref matrix i) j) (case bit 173 | (0 :light) (1 :dark)))) 174 | (defun bstream-placement (bstream matrix modules) 175 | "2X4 module block for a regular symbol character. Regard the interleaved 176 | codeword sequence as a single bit stream, which is placed in the two module 177 | wide columns, alternately in the right and left modules, moving upwards or 178 | downwards according to DIRECTION, skipping function patterns, changing DIRECTION 179 | at the top or bottom of the symbol. The only exception is that no block should 180 | ever overlap the vertical timing pattern." 181 | (let ((i (- modules 1)) 182 | (j (- modules 1)) 183 | ;; -1: upwards, +1: downwards 184 | (direction -1) 185 | (len (length bstream))) 186 | (do ((idx 0)) 187 | ((>= idx len) matrix) 188 | (when (raw-module-p matrix i j) 189 | (paint-color-bit matrix i j (nth idx bstream)) 190 | (incf idx)) 191 | (when (and (>= (- j 1) 0) 192 | (raw-module-p matrix i (- j 1))) 193 | ;; try left module 194 | (paint-color-bit matrix i (- j 1) (nth idx bstream)) 195 | (incf idx)) 196 | (if (< -1 (+ i direction) modules) 197 | (incf i direction) 198 | (progn 199 | ;; reverse direction 200 | (setf direction (- direction)) 201 | (if (= j 8) 202 | ;; vertical timing pattern reached, the next block starts 203 | ;; to the left of it 204 | (decf j 3) 205 | (decf j 2))))))) 206 | 207 | ;;; format information, during and after masking 208 | (defun format-information (matrix modules level mask-ind) 209 | ;; format information bistream 210 | (let ((fib (format-ecc level mask-ind)) 211 | (darks 0) 212 | (idx 0) 213 | (idx2 0)) 214 | (setf darks (count-if #'(lambda (elem) (= elem 1)) fib)) 215 | ;; horizontal 14 ~ 8 216 | (loop for j from 0 to 7 do 217 | (when (eq (aref (aref matrix 8) j) :reserve) 218 | (paint-fcolor-bit matrix 8 j (nth idx fib)) 219 | (incf idx))) 220 | ;; vertical 14 ~ 8 221 | (loop for i from (- modules 1) downto (- modules 7) do 222 | (paint-fcolor-bit matrix i 8 (nth idx2 fib)) 223 | (incf idx2)) 224 | ;; horizontal 7 - 0 225 | (loop for j from (- modules 8) to (- modules 1) do 226 | (paint-fcolor-bit matrix 8 j (nth idx fib)) 227 | (incf idx)) 228 | ;; vertical 7 - 0 229 | (loop for i from 8 downto 0 do 230 | (when (eq (aref (aref matrix i) 8) :reserve) 231 | (paint-fcolor-bit matrix i 8 (nth idx2 fib)) 232 | (incf idx2))) 233 | (values matrix darks))) 234 | -------------------------------------------------------------------------------- /qrencode/modes.el: -------------------------------------------------------------------------------- 1 | ;; -*- lexical-binding: t -*- 2 | 3 | ;;;; Copyright (c) 2011-2014 jnjcc, Yste.org. All rights reserved. 4 | ;;;; 5 | 6 | ;;(in-package #:cl-qrencode) 7 | (require 'cl) 8 | 9 | (deftype qr-mode () 10 | '(member :unknown 11 | :numeric :alnum :byte :kanji 12 | ;; Extended Channel Interpretation, Structured Append, FNC1 13 | :eci :structured :fnc1)) 14 | 15 | (defun mode-indicator (mode) 16 | (declare (type qr-mode mode)) 17 | (case mode 18 | (:numeric '(0 0 0 1)) ; "0001" 19 | (:alnum '(0 0 1 0)) ; "0010" 20 | (:byte '(0 1 0 0)) ; "0100" 21 | (:kanji '(1 0 0 0)) ; "1000" 22 | (:eci '(0 1 1 1)) ; "0111" 23 | (:structured '(0 0 1 1)) ; "0011" 24 | (:fnc1 '(0 1 0 1)))) ; FIXME: "0101" & "1001" 25 | 26 | (defun terminator (bstream version level) 27 | "End of message" 28 | (let* ((nbits (length bstream)) 29 | (diff (- (* (data-words-capacity version level) 8) 30 | nbits))) 31 | (cond 32 | ((< diff 0) (error "you serious about this?!")) 33 | ((<= diff 4) (make-list diff 0)) 34 | (t (make-list 4 0))))) 35 | 36 | (defun byte-value (mode byte) 37 | "BYTE value under MODE" 38 | (declare (type qr-mode mode)) 39 | (case mode 40 | (:numeric 41 | (and (<= #x30 byte #x39) 42 | (- byte #x30))) 43 | (:alnum 44 | (cond 45 | ((<= #x30 byte #x39) (- byte #x30)) ; 0-9 46 | ((<= #x41 byte #x5A) (+ (- byte #x41) 10)) ; A-Z 47 | ((= byte #x20) 36) ; SP 48 | ((= byte #x24) 37) ; $ 49 | ((= byte #x25) 38) ; % 50 | ((= byte #x2A) 39) ; * 51 | ((= byte #x2B) 40) ; + 52 | ((= byte #x2D) 41) ; - 53 | ((= byte #x2E) 42) ; . 54 | ((= byte #x2F) 43) ; / 55 | ((= byte #x3A) 44) ; : 56 | (t nil))) 57 | ((:byte :kanji) byte))) 58 | 59 | (defun kanji-word-p (word) 60 | "(kanji-p, kanji-range: {0, 1})" 61 | (cond 62 | ((<= #x8140 word #x9ffc) (values t 0)) 63 | ((<= #xe040 word #xebbf) (values t 1)) 64 | (t (values nil nil)))) 65 | 66 | (defun starts-kanji-p (bytes) 67 | "(BYTES starts with kanji-p, kanji word value, kanji-range: {0, 1})" 68 | (declare (type list bytes)) 69 | (let* ((first (car bytes)) 70 | (second (cadr bytes)) 71 | (word (and second (+ (ash first 8) second)))) 72 | (if (and first second) 73 | (multiple-value-bind (kanji-p range) 74 | (kanji-word-p word) 75 | (values kanji-p word range)) 76 | (values nil nil nil)))) 77 | 78 | (defun xor-subset-of (bytes) 79 | "exclusive subset of first unit of BYTES. 80 | as for unit, one byte for :numeric, :alnum; two bytes for :kanji" 81 | (declare (type list bytes)) 82 | (let* ((first (car bytes))) 83 | (cond 84 | ((null first) :unknown) 85 | ((byte-value :numeric first) :numeric) 86 | ((byte-value :alnum first) :alnum) 87 | ;; excluding reserved values 80-9F & E0-FF 88 | ((and (not (<= #x80 first #x9F)) 89 | (not (<= #xE0 first #xFF))) 90 | :byte) 91 | ((starts-kanji-p bytes) 92 | :kanji)))) 93 | -------------------------------------------------------------------------------- /qrencode/qrspec.el: -------------------------------------------------------------------------------- 1 | ;; -*- lexical-binding: t -*- 2 | 3 | ;;;; Original Common Lisp: 4 | ;;;; Copyright (c) 2011-2014 jnjcc, Yste.org. All rights reserved. 5 | ;;;; 6 | ;;;; Port to Emacs Lisp: 7 | ;;;; Copyright (c) 2015 Andrea Rossetti (http://andrear.altervista.org) 8 | 9 | (require 'cl) 10 | 11 | ;;; Table 1 - Codeword capacity of all versions of QR Code 2005 12 | ;;; excluding Micro QR Code, varies between version 13 | (defvar *codeword-capacity-table* 14 | [[-1 -1 -1 -1 -1 -1] ; 0, no such version 15 | [21 202 31 208 26 0] [25 235 31 359 44 7] 16 | [29 243 31 567 70 7] [33 251 31 807 100 7] 17 | [37 259 31 1079 134 7] [41 267 31 1383 172 7] 18 | [45 390 67 1568 196 0] [49 398 67 1936 242 0] 19 | [53 406 67 2336 292 0] [57 414 67 2768 346 0] ; Version 10 20 | [61 422 67 3232 404 0] [65 430 67 3728 466 0] 21 | [69 438 67 4256 532 0] [73 611 67 4651 581 3] 22 | [77 619 67 5243 655 3] [81 627 67 5867 733 3] 23 | [85 635 67 6523 815 3] [89 643 67 7211 901 3] 24 | [93 651 67 7931 991 3] [97 659 67 8683 1085 3] ; Version 20 25 | [101 882 67 9252 1156 4] [105 890 67 10068 1258 4] 26 | [109 898 67 10916 1364 4] [113 906 67 11796 1474 4] 27 | [117 914 67 12708 1588 4] [121 922 67 13652 1706 4] 28 | [125 930 67 14628 1828 4] [129 1203 67 15371 1921 3] 29 | [133 1211 67 16411 2051 3] [137 1219 67 17483 2185 3] ; Version 30 30 | [141 1227 67 18587 2323 3] [145 1235 67 19723 2465 3] 31 | [149 1243 67 20891 2611 3] [153 1251 67 22091 2761 3] 32 | [157 1574 67 23008 2876 0] [161 1582 67 24272 3034 0] 33 | [165 1590 67 25568 3196 0] [169 1598 67 26896 3362 0] 34 | [173 1606 67 28256 3532 0] [177 1614 67 29648 3706 0]] ; Version 40 35 | "Number of modules (as version increases, 4 modules added) A | Function pattern 36 | modules B | Format and Version information modules C | Data modules (A^2-B-C) | 37 | Data capacity codewords (bytes, including ecc codewords) | Remainder bits.") 38 | 39 | (defun codeword-capacity (version) 40 | "codeword: data word + ecc word" 41 | (aref (aref *codeword-capacity-table* version) 4)) 42 | (defun matrix-modules (version) 43 | (aref (aref *codeword-capacity-table* version) 0)) 44 | (defun remainder-bits (version) 45 | (aref (aref *codeword-capacity-table* version) 5)) 46 | 47 | (defun mode->index (mode) 48 | (case mode 49 | (:numeric 0) 50 | (:alnum 1) 51 | (:byte 2) 52 | (:kanji 3))) 53 | 54 | (deftype ecc-level () 55 | '(member :level-l :level-m :level-q :level-h)) 56 | (defun level->index (level) 57 | (case level 58 | (:level-l 0) 59 | (:level-m 1) 60 | (:level-q 2) 61 | (:level-h 3))) 62 | 63 | ;;; (Part I of) Table 9 - Number of Error Correction Codewords (bytes) 64 | ;;; varies between version and level 65 | (defvar *ecc-codewords-table* 66 | ;; (:level-l :level-m :level-q :level-h) 67 | [[-1 -1 -1 -1] ;; 0, no such version 68 | [7 10 13 17] [10 16 22 28] [15 26 36 44] 69 | [20 36 52 64] [26 48 72 88] [36 64 96 112] 70 | [40 72 108 130] [48 88 132 156] [60 110 160 192] 71 | [72 130 192 224] [80 150 224 264] [96 176 260 308] 72 | [104 198 288 352] [120 216 320 384] [132 240 360 432] 73 | [144 280 408 480] [168 308 448 532] [180 338 504 588] 74 | [196 364 546 650] [224 416 600 700] [224 442 644 750] 75 | [252 476 690 816] [270 504 750 900] [300 560 810 960] 76 | [312 588 870 1050] [336 644 952 1110] [360 700 1020 1200] 77 | [390 728 1050 1260] [420 784 1140 1350] [450 812 1200 1440] 78 | [480 868 1290 1530] [510 924 1350 1620] [540 980 1440 1710] 79 | [570 1036 1530 1800] [570 1064 1590 1890] [600 1120 1680 1980] 80 | [630 1204 1770 2100] [660 1260 1860 2220] [720 1316 1950 2310] 81 | [750 1372 2040 2430]]) ;; version 1 ~ 40 82 | (defun ecc-words-capacity (version level) 83 | (aref (aref *ecc-codewords-table* version) (level->index level))) 84 | 85 | (defun data-words-capacity (version level) 86 | (- (codeword-capacity version) (ecc-words-capacity version level))) 87 | 88 | ;;; (Part II of) Table 9 - Error Correction blocks 89 | ;;; varies between version and level 90 | (defvar *ecc-blocks* 91 | ;; (version, level) => 92 | ;; (# of ec codewords for each blk, # of blk 1, # of data words for blk 1, 93 | ;; # of blk 2, # of data words for blk 2) 94 | ;; :level-l :level-m :level-q :level-h 95 | [[[0 0 0 0 0] [0 0 0 0 0] [0 0 0 0 0] [0 0 0 0 0]] ; no such version 96 | [[7 1 19 0 0] [10 1 16 0 0] [13 1 13 0 0] [17 1 9 0 0]] ; Version 1 97 | [[10 1 34 0 0] [16 1 28 0 0] [22 1 22 0 0] [28 1 16 0 0]] 98 | [[15 1 55 0 0] [26 1 44 0 0] [18 2 17 0 0] [22 2 13 0 0]] 99 | [[20 1 80 0 0] [18 2 32 0 0] [26 2 24 0 0] [16 4 9 0 0]] 100 | [[26 1 108 0 0] [24 2 43 0 0] [18 2 15 2 16] [22 2 11 2 12]] ; Version 5 101 | [[18 2 68 0 0] [16 4 27 0 0] [24 4 19 0 0] [28 4 15 0 0]] 102 | [[20 2 78 0 0] [18 4 31 0 0] [18 2 14 4 15] [26 4 13 1 14]] 103 | [[24 2 97 0 0] [22 2 38 2 39] [22 4 18 2 19] [26 4 14 2 15]] 104 | [[30 2 116 0 0] [22 3 36 2 37] [20 4 16 4 17] [24 4 12 4 13]] 105 | [[18 2 68 2 69] [26 4 43 1 44] [24 6 19 2 20] [28 6 15 2 16]] ; Version 10 106 | [[20 4 81 0 0] [30 1 50 4 51] [28 4 22 4 23] [24 3 12 8 13]] 107 | [[24 2 92 2 93] [22 6 36 2 37] [26 4 20 6 21] [28 7 14 4 15]] 108 | [[26 4 107 0 0] [22 8 37 1 38] [24 8 20 4 21] [22 12 11 4 12]] 109 | [[30 3 115 1 116] [24 4 40 5 41] [20 11 16 5 17] [24 11 12 5 13]] 110 | [[22 5 87 1 88] [24 5 41 5 42] [30 5 24 7 25] [24 11 12 7 13]] ; Version 15 111 | [[24 5 98 1 99] [28 7 45 3 46] [24 15 19 2 20] [30 3 15 13 16]] 112 | [[28 1 107 5 108] [28 10 46 1 47] [28 1 22 15 23] [28 2 14 17 15]] 113 | [[30 5 120 1 121] [26 9 43 4 44] [28 17 22 1 23] [28 2 14 19 15]] 114 | [[28 3 113 4 114] [26 3 44 11 45] [26 17 21 4 22] [26 9 13 16 14]] 115 | [[28 3 107 5 108] [26 3 41 13 42] [30 15 24 5 25] [28 15 15 10 16]] ; Version 20 116 | [[28 4 116 4 117] [26 17 42 0 0] [28 17 22 6 23] [30 19 16 6 17]] 117 | [[28 2 111 7 112] [28 17 46 0 0] [30 7 24 16 25] [24 34 13 0 0]] 118 | [[30 4 121 5 122] [28 4 47 14 48] [30 11 24 14 25] [30 16 15 14 16]] 119 | [[30 6 117 4 118] [28 6 45 14 46] [30 11 24 16 25] [30 30 16 2 17]] 120 | [[26 8 106 4 107] [28 8 47 13 48] [30 7 24 22 25] [30 22 15 13 16]] ; Version 25 121 | [[28 10 114 2 115] [28 19 46 4 47] [28 28 22 6 23] [30 33 16 4 17]] 122 | [[30 8 122 4 123] [28 22 45 3 46] [30 8 23 26 24] [30 12 15 28 16]] 123 | [[30 3 117 10 118] [28 3 45 23 46] [30 4 24 31 25] [30 11 15 31 16]] 124 | [[30 7 116 7 117] [28 21 45 7 46] [30 1 23 37 24] [30 19 15 26 16]] 125 | [[30 5 115 10 116] [28 19 47 10 48] [30 15 24 25 25] [30 23 15 25 16]] ; Version 30 126 | [[30 13 115 3 116] [28 2 46 29 47] [30 42 24 1 25] [30 23 15 28 16]] 127 | [[30 17 115 0 0] [28 10 46 23 47] [30 10 24 35 25] [30 19 15 35 16]] 128 | [[30 17 115 1 116] [28 14 46 21 47] [30 29 24 19 25] [30 11 15 46 16]] 129 | [[30 13 115 6 116] [28 14 46 23 47] [30 44 24 7 25] [30 59 16 1 17]] 130 | [[30 12 121 7 122] [28 12 47 26 48] [30 39 24 14 25] [30 22 15 41 16]] ; Version 35 131 | [[30 6 121 14 122] [28 6 47 34 48] [30 46 24 10 25] [30 2 15 64 16]] 132 | [[30 17 122 4 123] [28 29 46 14 47] [30 49 24 10 25] [30 24 15 46 16]] 133 | [[30 4 122 18 123] [28 13 46 32 47] [30 48 24 14 25] [30 42 15 32 16]] 134 | [[30 20 117 4 118] [28 40 47 7 48] [30 43 24 22 25] [30 10 15 67 16]] 135 | [[30 19 118 6 119] [28 18 47 31 48] [30 34 24 34 25] [30 20 15 61 16]] ; Version 40 136 | ]) 137 | (defun ecc-block-nums (version level) 138 | "# of ec codewords for each blk, # of blk 1, # of data words for blk 1, ..." 139 | (let ((lidx (level->index level))) 140 | (values (aref (aref (aref *ecc-blocks* version) lidx) 0) 141 | (aref (aref (aref *ecc-blocks* version) lidx) 1) 142 | (aref (aref (aref *ecc-blocks* version) lidx) 2) 143 | (aref (aref (aref *ecc-blocks* version) lidx) 3) 144 | (aref (aref (aref *ecc-blocks* version) lidx) 4)))) 145 | 146 | (defun minimum-version (init-version nbytes level) 147 | "minimum version that can hold NBYTES data words, or INIT-VERSION if bigger" 148 | (block minimum-version-block 149 | (do ((v init-version (1+ v))) 150 | ((> v 40) nil) 151 | (when (>= (data-words-capacity v level) nbytes) 152 | (return-from minimum-version-block v))))) 153 | 154 | (defun version-range (version) 155 | (cond 156 | ((<= 1 version 9) 0) 157 | ((<= 10 version 26) 1) 158 | ((<= 27 version 40) 2))) 159 | 160 | ;;; Table 3 - Number of bits in character count indicator for QR Code 2005 161 | (defvar *char-count-indicator* 162 | ;; :numeric :alnum :byte :kanji 163 | [[10 9 8 8] ; version-range 0 164 | [12 11 16 10] ; version-range 1 165 | [14 13 16 12]]) ; version-range 2 166 | 167 | (defun char-count-bits (version mode) 168 | (let ((i (version-range version)) 169 | (j (mode->index mode))) 170 | (aref (aref *char-count-indicator* i) j))) 171 | 172 | ;;; Table E.1 - Row/column coordinates of center modules of alignment patterns 173 | ;;; varies between versions 174 | (defvar *align-coord-table* 175 | [[0 []] ; 0, no such version 176 | [0 []] [1 [6 18]] [1 [6 22]] 177 | [1 [6 26]] [1 [6 30]] [1 [6 34]] 178 | [6 [6 22 38]] [6 [6 24 42]] [6 [6 26 46]] 179 | [6 [6 28 50]] [6 [6 30 54]] [6 [6 32 58]] 180 | [6 [6 34 62]] [13 [6 26 46 66]] [13 [6 26 48 70]] 181 | [13 [6 26 50 74]] [13 [6 30 54 78]] [13 [6 30 56 82]] 182 | [13 [6 30 58 86]] [13 [6 34 62 90]] [22 [6 28 50 72 94]] 183 | [22 [6 26 50 74 98]] [22 [6 30 54 78 102]] [22 [6 28 54 80 106]] 184 | [22 [6 32 58 84 110]] [22 [6 30 58 86 114]] [22 [6 34 62 90 118]] 185 | [33 [6 26 50 74 98 122]] [33 [6 30 54 78 102 126]] [33 [6 26 52 78 104 130]] 186 | [33 [6 30 56 82 108 134]] [33 [6 34 60 86 112 138]] [33 [6 30 58 86 114 142]] 187 | [33 [6 34 62 90 118 146]] [46 [6 30 54 78 102 126 150]] [46 [6 24 50 76 102 128 154]] 188 | [46 [6 28 54 80 106 132 158]] [46 [6 32 58 84 110 136 162]] [46 [6 26 54 82 110 138 166]] 189 | [46 [6 30 58 86 114 142 170]]] 190 | "# of Alignment Patterns, row/column coordinates of center modules.") 191 | 192 | (defun valid-center-p (x y modules) 193 | "The alignment center module is not in Finder Patterns." 194 | (not (or (and (<= 0 x 8) (<= 0 y 8)) ; upleft finder pattern 195 | (and (<= 0 x 8) 196 | (<= (- modules 8) y (- modules 1))) ; upright finder pattern 197 | (and (<= (- modules 8) x (- modules 1)) 198 | (<= 0 y 8))))) 199 | (defun align-centers (version) 200 | "list of all valid alignment pattern center modules under VERSION" 201 | (let* ((modules (matrix-modules version)) 202 | (coords (coerce (aref (aref *align-coord-table* version) 1) 'list)) 203 | (len (length coords)) 204 | (centers nil)) 205 | (dotimes (i len) 206 | (loop for j from i to (- len 1) do 207 | (let ((x (nth i coords)) 208 | (y (nth j coords))) 209 | (when (valid-center-p x y modules) 210 | (push (list x y) centers)) 211 | (unless (= x y) 212 | (when (valid-center-p y x modules) 213 | (push (list y x) centers)))))) 214 | centers)) 215 | 216 | (defvar *mask-pattern-num* 8) 217 | (defun mask-condition (indicator) 218 | (lambda (i j) 219 | (case indicator 220 | ;; (i + j) mod 2 == 0 221 | (0 (= (mod (+ i j) 2) 0)) 222 | ;; i mod 2 == 0 223 | (1 (= (mod i 2) 0)) 224 | ;; j mod 3 == 0 225 | (2 (= (mod j 3) 0)) 226 | ;; (i + j) mod 3 == 0 227 | (3 (= (mod (+ i j) 3) 0)) 228 | ;; ((i/2) + (j/3)) mod 2 == 0 229 | (4 (= (mod (+ (floor i 2) (floor j 3)) 2) 0)) 230 | ;; (i*j) mod 2 + (i*j) mod 3 == 0 231 | (5 (= (+ (mod (* i j) 2) (mod (* i j) 3)) 0)) 232 | ;; ((i*j) mod 2 + (i*j) mod 3)) mod 2 == 0 233 | (6 (= (mod (+ (mod (* i j) 2) (mod (* i j) 3)) 2) 0)) 234 | ;; ((i+j) mod 2 + (i*j) mod 3)) mod 2 == 0 235 | (7 (= (mod (+ (mod (+ i j) 2) (mod (* i j) 3)) 2) 0))))) 236 | 237 | (defvar *ecc-level-indicator* [(0 1) (0 0) (1 1) (1 0)] 238 | ":level-l :level-m :level-q :level-h") 239 | (defun level-indicator (level) 240 | (aref *ecc-level-indicator* (level->index level))) 241 | (defvar *mask-pattern-reference* 242 | [(0 0 0) (0 0 1) (0 1 0) (0 1 1) 243 | (1 0 0) (1 0 1) (1 1 0) (1 1 1)]) 244 | (defun mask-pattern-ref (ind) 245 | (aref *mask-pattern-reference* ind)) 246 | -------------------------------------------------------------------------------- /rs-ecc/bch-ecc.el: -------------------------------------------------------------------------------- 1 | ;; -*- lexical-binding: t -*- 2 | 3 | ;;;; Copyright (c) 2011-2014 jnjcc, Yste.org. All rights reserved. 4 | ;;;; 5 | ;;;; Bose-Chaudhuri-Hocquenghem (BCH) error correction code 6 | 7 | ;; (in-package #:cl-qrencode) 8 | (require 'cl) 9 | (require 'eieio) 10 | 11 | ;;; Polynomial (using list) arithmetics 12 | ;;; by polynomial list (3 2 1), we mean 3*x^2 + 2*x + 1 13 | (defun poly-ash (poly s) 14 | "shift left POLY by S" 15 | (append poly (make-list s 0))) 16 | (defun poly-multiply (poly b op) 17 | "multiply B on every element of POLY using OP" 18 | (when (null op) (setf op #'*)) 19 | (cl-labels ((mult (elem) 20 | (funcall op elem b))) 21 | (mapcar #'mult poly))) 22 | (defun poly-multiply-2-args (poly b) 23 | "multiply B on every element of POLY using OP" 24 | (poly-multiply poly b #'*)) 25 | (defun poly-substract (lhs rhs op) 26 | (when (null op) (setf op #'-)) 27 | (cl-labels ((sub (elem1 elem2) 28 | (funcall op elem1 elem2))) 29 | (map 'list #'sub lhs rhs))) 30 | (defun poly-mod (msg gen rem sub mul) 31 | "MSG % GEN, with REM remainders" 32 | (when (null sub) (setf sub #'poly-substract)) 33 | (when (null mul) (setf mul #'poly-multiply-2-args)) 34 | (do ((m (poly-ash msg rem) (cdr m))) 35 | ((<= (length m) rem) m) 36 | (let* ((glen (length gen)) 37 | (sft (- (length m) glen)) 38 | ;; LEAD coffiecient of message polynomial 39 | (lead (car m))) 40 | (setf m (funcall sub m (poly-ash (funcall mul gen lead) sft)))))) 41 | 42 | (defclass bch-ecc () 43 | ((k :initform nil :initarg :k 44 | :documentation "# of data codewords") 45 | (ec :initform nil :initarg :ec 46 | :documentation "# of error correction codewords"))) 47 | 48 | (defun bch* (poly b) 49 | (poly-multiply-2-args poly b)) 50 | (defun bch- (lhs rhs) 51 | (cl-labels ((xor (a b) 52 | (logxor a b))) 53 | (poly-substract lhs rhs #'xor))) 54 | (defun bch-xor (lhs rhs) 55 | (cl-labels ((xor (a b) 56 | (logxor a b))) 57 | (map 'list #'xor lhs rhs))) 58 | (defun bch% (msg gen rem) 59 | (poly-mod msg gen rem #'bch- #'bch*)) 60 | 61 | (defgeneric make-bch-ecc (bch msgpoly genpoly) 62 | "do bch error correction under BCH(K+EC, K)") 63 | 64 | (defmethod make-bch-ecc ((bch bch-ecc) msg gen) 65 | (with-slots (k ec) bch 66 | (unless (= (length msg) k) 67 | (error "wrong msg length, expect: %s; got: %s" k (length msg))) 68 | (bch% msg gen ec))) 69 | 70 | ;;; As used by format information ecc & version information ecc respectively 71 | ;;; BCH(15, 5) & BCH(18, 6) 72 | (let ((fi-ecc (make-instance 'bch-ecc :k 5 :ec 10)) 73 | ;; format information generator polynomial 74 | ;; x^10 + x^8 + x^5 + x^4 + x^2 + x + 1 75 | (fi-gpoly '(1 0 1 0 0 1 1 0 1 1 1)) 76 | (fi-xor '(1 0 1 0 1 0 0 0 0 0 1 0 0 1 0))) 77 | (defun format-ecc (level mask-ind) 78 | (let ((seq (append (level-indicator level) 79 | (mask-pattern-ref mask-ind)))) 80 | (bch-xor (append seq (make-bch-ecc fi-ecc seq fi-gpoly)) 81 | fi-xor)))) 82 | 83 | (let ((vi-ecc (make-instance 'bch-ecc :k 6 :ec 12)) 84 | ;; version information generator polynomial 85 | ;; x^12 + x^11 + x^10 + x^9 + x^8 + x^5 + x^2 + 1 86 | (vi-gpoly '(1 1 1 1 1 0 0 1 0 0 1 0 1))) 87 | (defun version-ecc (version) 88 | (let ((seq (decimal->bstream version 6))) 89 | (append seq (make-bch-ecc vi-ecc seq vi-gpoly))))) 90 | -------------------------------------------------------------------------------- /rs-ecc/galois.el: -------------------------------------------------------------------------------- 1 | ;; -*- lexical-binding: t -*- 2 | 3 | ;;;; Copyright (c) 2011-2014 jnjcc, Yste.org. All rights reserved. 4 | ;;;; 5 | ;;;; Galois Field with primitive element 2, as used by Reed-Solomon code 6 | 7 | ;; (in-package #:cl-qrencode) 8 | (require 'cl) 9 | (require 'eieio) 10 | 11 | (defclass galois () 12 | ((power :initform nil :initarg :power :reader gf-power 13 | :documentation "Galois Field GF(2^POWER)") 14 | (prime-poly :initform nil :initarg :ppoly :reader prime-poly 15 | :documentation "prime polynomial") 16 | (order :initform nil :reader gf-order) 17 | (exp-table :initform nil) 18 | (log-table :initform nil))) 19 | 20 | (defmethod initialize-instance :after ((gf galois) &rest args) 21 | (declare (ignore args)) 22 | (setf (slot-value gf 'order) (ash 1 (slot-value gf 'power))) 23 | (let* ((order (gf-order gf)) 24 | (ppoly (prime-poly gf)) 25 | ;; 2^0 = 1 && (log 0) = -1 26 | (exptab (make-vector order 1)) 27 | (logtab (make-vector order -1))) 28 | (do ((i 1 (1+ i))) 29 | ((>= i order)) 30 | (setf (aref exptab i) (* (aref exptab (- i 1)) 2)) 31 | (when (>= (aref exptab i) order) 32 | (setf (aref exptab i) 33 | (logand (- order 1) 34 | (logxor (aref exptab i) ppoly)))) 35 | (setf (aref logtab (aref exptab i)) i)) 36 | (setf (aref logtab 1) 0) 37 | (setf (slot-value gf 'exp-table) exptab) 38 | (setf (slot-value gf 'log-table) logtab))) 39 | 40 | ;;; value accessor 41 | (defgeneric gf-exp (gf pow) 42 | "2^POW under Galois Field GF") 43 | (defgeneric gf-log (gf value) 44 | "VALUE should be within range [0, 2^POW - 1]") 45 | 46 | (defmethod gf-exp ((gf galois) pow) 47 | (let* ((sz (- (gf-order gf) 1)) 48 | (idx (mod pow sz))) 49 | (aref (slot-value gf 'exp-table) idx))) 50 | 51 | (defmethod gf-log ((gf galois) value) 52 | (let* ((sz (gf-order gf)) 53 | (idx (mod value sz))) 54 | (aref (slot-value gf 'log-table) idx))) 55 | 56 | ;;; Galois Field arithmetic 57 | (defgeneric gf-add (gf a b)) 58 | (defgeneric gf-subtract (gf a b)) 59 | (defgeneric gf-multiply (gf a b)) 60 | (defgeneric gf-divide (gf a b)) 61 | 62 | (defmethod gf-add ((gf galois) a b) 63 | (logxor a b)) 64 | 65 | (defmethod gf-subtract ((gf galois) a b) 66 | (logxor a b)) 67 | 68 | (defmethod gf-multiply ((gf galois) a b) 69 | (let ((sum (+ (gf-log gf a) (gf-log gf b)))) 70 | (gf-exp gf sum))) 71 | 72 | (defmethod gf-divide ((gf galois) a b) 73 | (when (= b 0) 74 | (error "divide by zero")) 75 | (if (= a 0) 76 | 0 77 | (let ((sub (- (gf-log gf a) (gf-log gf b)))) 78 | (gf-exp gf sub)))) 79 | 80 | ;;; open-paren at beg of line confuses `slime-compile-defun` which uses 81 | ;;; elisp function `beginning-of-defun`, which in turn involves 82 | ;;; backward-searching open-paren at beg of line 83 | ;;; there seems to be no easy way to fix this problem 84 | ;; with an extra leading '\', docstring is kind of ulgy now, though 85 | (defmacro with-gf-accessors (accessors gf &body body) 86 | "shortcuts for gf-exp & gf-log, usage: 87 | \(with-gf-accessors ((gfexp gf-exp)) *gf-instance* ...)" 88 | `(cl-labels ,(mapcar (lambda (acc-entry) 89 | (let ((acc-name (car acc-entry)) 90 | (method-name (cadr acc-entry))) 91 | `(,acc-name (a) 92 | (,method-name ,gf a)))) 93 | accessors) 94 | ,@body)) 95 | 96 | (defmacro with-gf-arithmetics (ariths gf &body body) 97 | "shortcuts for gf-add, gf-subtract, gf-multiply & gf-divide, usage: 98 | \(with-gf-arithmetics ((gf+ gf-add)) *gf-instance* ...)" 99 | `(cl-labels ,(mapcar (lambda (arith-entry) 100 | (let ((arith-name (car arith-entry)) 101 | (method-name (cadr arith-entry))) 102 | `(,arith-name (a b) 103 | (,method-name ,gf a b)))) 104 | ariths) 105 | ,@body)) 106 | 107 | (defmacro with-gf-shortcuts (accessors ariths gf &body body) 108 | "combined with-gf-accessors & with-gf-arithmetics, usage: 109 | \(with-gf-shortcuts ((gflog gf-log)) ((gf* gf-multiply)) *gf-instance* ...)" 110 | `(cl-labels ,(append 111 | (mapcar (lambda (acc-entry) 112 | (let ((acc-name (car acc-entry)) 113 | (method-name (cadr acc-entry))) 114 | `(,acc-name (a) 115 | (,method-name ,gf a)))) 116 | accessors) 117 | (mapcar (lambda (arith-entry) 118 | (let ((arith-name (car arith-entry)) 119 | (method-name (cadr arith-entry))) 120 | `(,arith-name (a b) 121 | (,method-name ,gf a b)))) 122 | ariths)) 123 | ,@body)) 124 | -------------------------------------------------------------------------------- /rs-ecc/rs-ecc.el: -------------------------------------------------------------------------------- 1 | ;; -*- lexical-binding: t -*- 2 | 3 | ;;;; Copyright (c) 2011-2014 jnjcc, Yste.org. All rights reserved. 4 | ;;;; 5 | ;;;; Reed-Solomon error correction code as used by QR code 6 | 7 | ;;(in-package #:cl-qrencode) 8 | (require 'cl) 9 | (require 'eieio) 10 | 11 | ;;; Reed-Solomon code uses GF(2^8) with prime polynomial 285, 12 | ;;; or 1,0001,1101, or (x^8 + x^4 + x^3 + x^2 + 1) 13 | (defvar gf256 (make-instance 'galois :power 8 :ppoly 285)) 14 | (defun gf* (a b) (gf-multiply gf256 a b)) 15 | (defun gf+ (a b) (gf-add gf256 a b)) 16 | (defun gf- (a b) (gf-subtract gf256 a b)) 17 | (defun gfexp (pw) (gf-exp gf256 pw)) 18 | (defun gflog (pw) (gf-log gf256 pw)) 19 | 20 | ;; Polynomial arithmetics under GF(2^8), as used by Reed-Solomon ecc 21 | (defun rs* (poly b) 22 | "multiply B on every element of POLY under GF(2^8)" 23 | (poly-multiply poly b #'gf*)) 24 | 25 | (defun rs- (lhs rhs) 26 | (poly-substract lhs rhs #'gf-)) 27 | 28 | (defun rs% (msg gen rem) 29 | (poly-mod msg gen rem #'rs- #'rs*)) 30 | 31 | (defclass rs-ecc () 32 | ((k :initform nil :initarg :k 33 | :documentation "# of data codewords") 34 | (ec :initform nil :initarg :ec 35 | :documentation "# of error correction codewords") 36 | (gpoly :initform nil :reader gpoly 37 | :documentation "with EC, we calculate generator poly immediately"))) 38 | 39 | (defmethod initialize-instance :after ((rs rs-ecc) &rest args) 40 | (declare (ignore args)) 41 | (setf (slot-value rs 'gpoly) (gen-poly rs))) 42 | 43 | (defgeneric gen-poly (rs)) 44 | (defmethod gen-poly ((rs rs-ecc)) 45 | "Generator Polynomial: (x-a^0) * (x-a^1) * ... * (x-a^(ec-1))" 46 | (with-slots (ec) rs 47 | (let* ((size (+ ec 1)) 48 | (poly (make-list size nil))) 49 | (setf (nth 0 poly) 1 50 | (nth 1 poly) 1) 51 | (do ((i 2 (1+ i))) 52 | ((> i ec) poly) 53 | (setf (nth i poly) 1) 54 | (do ((j (- i 1) (1- j))) 55 | ((<= j 0)) 56 | (if (not (= (nth j poly) 0)) 57 | (setf (nth j poly) 58 | (gf+ (nth (- j 1) poly) 59 | (gf* (nth j poly) (gfexp (- i 1))))) 60 | (setf (nth j poly) (nth (- j 1) poly)))) 61 | (setf (nth 0 poly) (gf* (nth 0 poly) (gfexp (- i 1))))) 62 | (reverse poly)))) 63 | 64 | (defgeneric gen-poly-gflog (rs)) 65 | (defgeneric ecc-poly (rs msg)) 66 | 67 | (defmethod gen-poly-gflog ((rs rs-ecc)) 68 | ;; GPOLY already calculated when making new instance 69 | (mapcar #'gflog (gpoly rs))) 70 | 71 | (defmethod ecc-poly ((rs rs-ecc) msg-poly) 72 | "Error Correction codewords Polynomial for MSG-POLY" 73 | (with-slots (k ec gpoly) rs 74 | (unless (= (length msg-poly) k) 75 | (dbg "wrong msg-poly length, expect: ~A~%" k)) 76 | (rs% msg-poly gpoly ec))) 77 | 78 | -------------------------------------------------------------------------------- /test.el: -------------------------------------------------------------------------------- 1 | (require 'ert) 2 | 3 | (ert-deftest 4 | test-01-copy-and-mask () "test copy-and-mask on a 21x21 matrix" 5 | (should 6 | (equal 7 | (copy-and-mask [[:fdark :fdark :fdark :fdark :fdark :fdark :fdark :flight :reserve :light :dark :dark :dark :flight :fdark :fdark :fdark :fdark :fdark :fdark :fdark] 8 | [:fdark :flight :flight :flight :flight :flight :fdark :flight :reserve :dark :light :light :dark :flight :fdark :flight :flight :flight :flight :flight :fdark] 9 | [:fdark :flight :fdark :fdark :fdark :flight :fdark :flight :reserve :dark :light :dark :light :flight :fdark :flight :fdark :fdark :fdark :flight :fdark] 10 | [:fdark :flight :fdark :fdark :fdark :flight :fdark :flight :reserve :dark :light :light :dark :flight :fdark :flight :fdark :fdark :fdark :flight :fdark] 11 | [:fdark :flight :fdark :fdark :fdark :flight :fdark :flight :reserve :dark :light :light :light :flight :fdark :flight :fdark :fdark :fdark :flight :fdark] 12 | [:fdark :flight :flight :flight :flight :flight :fdark :flight :reserve :light :light :dark :dark :flight :fdark :flight :flight :flight :flight :flight :fdark] 13 | [:fdark :fdark :fdark :fdark :fdark :fdark :fdark :flight :fdark :flight :fdark :flight :fdark :flight :fdark :fdark :fdark :fdark :fdark :fdark :fdark] 14 | [:flight :flight :flight :flight :flight :flight :flight :flight :reserve :dark :light :light :dark :flight :flight :flight :flight :flight :flight :flight :flight] 15 | [:reserve :reserve :reserve :reserve :reserve :reserve :fdark :reserve :reserve :dark :light :dark :dark :reserve :reserve :reserve :reserve :reserve :reserve :reserve :reserve] 16 | [:dark :dark :light :light :dark :light :flight :light :dark :dark :dark :dark :light :dark :dark :dark :light :light :dark :light :dark] 17 | [:dark :dark :dark :dark :dark :light :fdark :dark :dark :dark :light :light :light :light :dark :light :light :dark :light :dark :light] 18 | [:dark :dark :light :light :light :light :flight :light :light :dark :light :dark :light :dark :dark :dark :light :dark :light :dark :dark] 19 | [:dark :dark :dark :light :dark :dark :fdark :dark :dark :dark :light :light :light :light :light :light :light :light :dark :light :light] 20 | [:flight :flight :flight :flight :flight :flight :flight :flight :fdark :light :dark :light :light :light :light :light :light :light :light :light :dark] 21 | [:fdark :fdark :fdark :fdark :fdark :fdark :fdark :flight :reserve :dark :light :dark :dark :dark :light :dark :dark :dark :light :dark :light] 22 | [:fdark :flight :flight :flight :flight :flight :fdark :flight :reserve :light :light :light :dark :light :light :light :dark :dark :light :light :light] 23 | [:fdark :flight :fdark :fdark :fdark :flight :fdark :flight :reserve :light :dark :dark :dark :dark :light :dark :dark :light :dark :dark :light] 24 | [:fdark :flight :fdark :fdark :fdark :flight :fdark :flight :reserve :light :dark :dark :light :dark :dark :light :light :dark :dark :light :light] 25 | [:fdark :flight :fdark :fdark :fdark :flight :fdark :flight :reserve :light :light :light :light :light :dark :light :light :dark :dark :light :light] 26 | [:fdark :flight :flight :flight :flight :flight :fdark :flight :reserve :dark :dark :dark :light :dark :dark :light :light :light :light :light :light] 27 | [:fdark :fdark :fdark :fdark :fdark :fdark :fdark :flight :reserve :light :dark :light :light :light :light :light :light :light :light :dark :light]] 28 | 21 :level-m 0) 29 | (list 30 | [[:fdark :fdark :fdark :fdark :fdark :fdark :fdark :flight :flight :light :light :dark :light :flight :fdark :fdark :fdark :fdark :fdark :fdark :fdark] 31 | [:fdark :flight :flight :flight :flight :flight :fdark :flight :fdark :light :light :dark :dark :flight :fdark :flight :flight :flight :flight :flight :fdark] 32 | [:fdark :flight :fdark :fdark :fdark :flight :fdark :flight :flight :dark :dark :dark :dark :flight :fdark :flight :fdark :fdark :fdark :flight :fdark] 33 | [:fdark :flight :fdark :fdark :fdark :flight :fdark :flight :flight :light :light :dark :dark :flight :fdark :flight :fdark :fdark :fdark :flight :fdark] 34 | [:fdark :flight :fdark :fdark :fdark :flight :fdark :flight :fdark :dark :dark :light :dark :flight :fdark :flight :fdark :fdark :fdark :flight :fdark] 35 | [:fdark :flight :flight :flight :flight :flight :fdark :flight :flight :dark :light :light :dark :flight :fdark :flight :flight :flight :flight :flight :fdark] 36 | [:fdark :fdark :fdark :fdark :fdark :fdark :fdark :flight :fdark :flight :fdark :flight :fdark :flight :fdark :fdark :fdark :fdark :fdark :fdark :fdark] 37 | [:flight :flight :flight :flight :flight :flight :flight :flight :flight :light :light :dark :dark :flight :flight :flight :flight :flight :flight :flight :flight] 38 | [:fdark :flight :fdark :flight :fdark :flight :fdark :flight :flight :dark :dark :dark :light :flight :flight :flight :fdark :flight :flight :fdark :flight] 39 | [:dark :light :light :dark :dark :dark :flight :dark :dark :light :dark :light :light :light :dark :light :light :dark :dark :dark :dark] 40 | [:light :dark :light :dark :light :light :fdark :dark :light :dark :dark :light :dark :light :light :light :dark :dark :dark :dark :dark] 41 | [:dark :light :light :dark :light :dark :flight :dark :light :light :light :light :light :light :dark :light :light :light :light :light :dark] 42 | [:light :dark :light :light :light :dark :fdark :dark :light :dark :dark :light :dark :light :dark :light :dark :light :light :light :dark] 43 | [:flight :flight :flight :flight :flight :flight :flight :flight :fdark :dark :dark :dark :light :dark :light :dark :light :dark :light :dark :dark] 44 | [:fdark :fdark :fdark :fdark :fdark :fdark :fdark :flight :flight :dark :dark :dark :light :dark :dark :dark :light :dark :dark :dark :dark] 45 | [:fdark :flight :flight :flight :flight :flight :fdark :flight :flight :dark :light :dark :dark :dark :light :dark :dark :light :light :dark :light] 46 | [:fdark :flight :fdark :fdark :fdark :flight :fdark :flight :fdark :light :light :dark :light :dark :dark :dark :light :light :light :dark :dark] 47 | [:fdark :flight :fdark :fdark :fdark :flight :fdark :flight :flight :dark :dark :light :light :light :dark :dark :light :light :dark :dark :light] 48 | [:fdark :flight :fdark :fdark :fdark :flight :fdark :flight :fdark :light :dark :light :dark :light :light :light :dark :dark :light :light :dark] 49 | [:fdark :flight :flight :flight :flight :flight :fdark :flight :flight :light :dark :light :light :light :dark :dark :light :dark :light :dark :light] 50 | [:fdark :fdark :fdark :fdark :fdark :fdark :fdark :flight :fdark :light :light :light :dark :light :dark :light :dark :light :dark :dark :dark]] 51 | 221)))) 52 | 53 | (ert-deftest 54 | test-02-encsym1 () "a simple qr code generation" 55 | (should 56 | (equal 57 | (matrix (encode-symbol "ciao" nil nil nil)) 58 | [[:fdark :fdark :fdark :fdark :fdark :fdark :fdark :flight :fdark :dark :dark :dark :light :flight :fdark :fdark :fdark :fdark :fdark :fdark :fdark] 59 | [:fdark :flight :flight :flight :flight :flight :fdark :flight :fdark :dark :light :dark :dark :flight :fdark :flight :flight :flight :flight :flight :fdark] 60 | [:fdark :flight :fdark :fdark :fdark :flight :fdark :flight :flight :dark :dark :dark :light :flight :fdark :flight :fdark :fdark :fdark :flight :fdark] 61 | [:fdark :flight :fdark :fdark :fdark :flight :fdark :flight :fdark :light :light :light :light :flight :fdark :flight :fdark :fdark :fdark :flight :fdark] 62 | [:fdark :flight :fdark :fdark :fdark :flight :fdark :flight :flight :dark :light :dark :light :flight :fdark :flight :fdark :fdark :fdark :flight :fdark] 63 | [:fdark :flight :flight :flight :flight :flight :fdark :flight :flight :light :dark :dark :dark :flight :fdark :flight :flight :flight :flight :flight :fdark] 64 | [:fdark :fdark :fdark :fdark :fdark :fdark :fdark :flight :fdark :flight :fdark :flight :fdark :flight :fdark :fdark :fdark :fdark :fdark :fdark :fdark] 65 | [:flight :flight :flight :flight :flight :flight :flight :flight :fdark :dark :light :dark :dark :flight :flight :flight :flight :flight :flight :flight :flight] 66 | [:fdark :flight :fdark :fdark :flight :fdark :fdark :fdark :flight :dark :dark :dark :dark :flight :fdark :flight :flight :fdark :flight :fdark :fdark] 67 | [:light :dark :light :dark :dark :light :flight :light :dark :light :dark :dark :dark :dark :dark :light :light :light :light :light :dark] 68 | [:dark :dark :light :dark :dark :dark :fdark :dark :light :dark :light :dark :light :light :light :light :light :light :light :dark :dark] 69 | [:dark :light :light :light :dark :light :flight :dark :light :dark :dark :dark :light :light :dark :dark :dark :dark :light :light :dark] 70 | [:light :dark :dark :dark :dark :dark :fdark :dark :dark :light :light :light :dark :light :light :dark :light :light :light :light :light] 71 | [:flight :flight :flight :flight :flight :flight :flight :flight :fdark :light :dark :dark :light :light :dark :light :light :dark :light :light :light] 72 | [:fdark :fdark :fdark :fdark :fdark :fdark :fdark :flight :fdark :dark :dark :dark :dark :light :light :dark :light :dark :light :light :light] 73 | [:fdark :flight :flight :flight :flight :flight :fdark :flight :fdark :dark :light :light :light :light :light :dark :dark :dark :dark :light :light] 74 | [:fdark :flight :fdark :fdark :fdark :flight :fdark :flight :flight :light :dark :light :dark :dark :dark :dark :dark :dark :dark :dark :dark] 75 | [:fdark :flight :fdark :fdark :fdark :flight :fdark :flight :fdark :light :light :dark :light :light :dark :light :dark :dark :dark :dark :light] 76 | [:fdark :flight :fdark :fdark :fdark :flight :fdark :flight :fdark :dark :light :light :dark :light :dark :dark :light :dark :light :light :light] 77 | [:fdark :flight :flight :flight :flight :flight :fdark :flight :flight :dark :dark :light :light :dark :light :light :light :dark :light :light :dark] 78 | [:fdark :fdark :fdark :fdark :fdark :fdark :fdark :flight :fdark :light :light :light :light :dark :light :light :dark :light :light :light :light]]))) 79 | 80 | (ert t) 81 | --------------------------------------------------------------------------------