1.1--- a/lisp/lib/cry/crc64.lisp Sat Mar 23 21:28:11 2024 -0400
1.2+++ b/lisp/lib/cry/crc64.lisp Sat Mar 23 23:02:31 2024 -0400
1.3@@ -36,12 +36,14 @@
1.4 ;; Lookup tables.
1.5 ;; We store high and low order bytes separately to benefit from
1.6 ;; 32 bit arithmentic performance.
1.7+
1.8 (declaim (type (array (unsigned-byte 32) (256)) *crc-table-h* *crc-table-l*))
1.9 (defvar *crc-table-h* (make-array 256 :element-type '(unsigned-byte 32)))
1.10 (defvar *crc-table-l* (make-array 256 :element-type '(unsigned-byte 32)))
1.11
1.12 (defun init-crc64 (polynomial)
1.13- "Computes lookup tables of CRC values for byte values 0 thru 255"
1.14+ "Computes lookup tables of CRC values for byte values 0 thru 255. Don't
1.15+forget to call this before calling the library functions."
1.16 (dotimes (i 256)
1.17 (let ((part i))
1.18 (dotimes (j 8)
2.1--- a/lisp/lib/cry/cry.asd Sat Mar 23 21:28:11 2024 -0400
2.2+++ b/lisp/lib/cry/cry.asd Sat Mar 23 23:02:31 2024 -0400
2.3@@ -1,4 +1,4 @@
2.4-(defsystem :crypto
2.5+(defsystem :cry
2.6 :version "0.1.0"
2.7 :maintainer "ellis <ellis@rwest.io>"
2.8 :bug-tracker "https://vc.compiler.company/comp/core/issues"
3.1--- a/lisp/lib/cry/hotp.lisp Sat Mar 23 21:28:11 2024 -0400
3.2+++ b/lisp/lib/cry/hotp.lisp Sat Mar 23 23:02:31 2024 -0400
3.3@@ -1,6 +1,43 @@
3.4 ;;; crypto/hotp.lisp --- HMAC-Based One-Time Passwords
3.5
3.6+;; see https://github.com/bhyde/cl-one-time-passwords/hotp.lisp
3.7+
3.8 ;; RFC 4226
3.9
3.10 ;;; Code:
3.11-(in-package :crypto/hotp)
3.12+(in-package :cry/hotp)
3.13+
3.14+(defvar *digits* 6)
3.15+
3.16+(defvar *hmac-sha-mode* :sha1)
3.17+
3.18+(defun hotp (key-string counter)
3.19+ (hotp-truncate (hmac-sha-n key-string counter)))
3.20+
3.21+(defun hotp-truncate (20-bytes)
3.22+ (flet ((dt (ht)
3.23+ (let* ((byte19 (aref ht 19))
3.24+ (byte-offset (ldb (byte 4 0) byte19))
3.25+ (result 0))
3.26+ (setf (ldb (byte 7 24) result) (aref ht byte-offset))
3.27+ (setf (ldb (byte 8 16) result) (aref ht (+ 1 byte-offset)))
3.28+ (setf (ldb (byte 8 8) result) (aref ht (+ 2 byte-offset)))
3.29+ (setf (ldb (byte 8 0) result) (aref ht (+ 3 byte-offset)))
3.30+ result)))
3.31+ (let ((sbits (dt 20-bytes)))
3.32+ (mod sbits
3.33+ (svref #(1 10 100 1000 10000 100000 1000000 10000000 100000000)
3.34+ *digits*)))))
3.35+
3.36+(defun hmac-sha-n (key-string counter)
3.37+ (loop
3.38+ with counter-bytes = (make-array 8 :element-type '(unsigned-byte 8))
3.39+ with hmac = (ironclad:make-hmac
3.40+ (ironclad:hex-string-to-byte-array key-string)
3.41+ *hmac-sha-mode*)
3.42+ finally
3.43+ (ironclad:update-hmac hmac counter-bytes)
3.44+ (return (ironclad:hmac-digest hmac))
3.45+ for i from 7 downto 0
3.46+ for offset from 0 by 8
3.47+ do (setf (aref counter-bytes i) (ldb (byte 8 offset) counter))))
4.1--- a/lisp/lib/cry/pkg.lisp Sat Mar 23 21:28:11 2024 -0400
4.2+++ b/lisp/lib/cry/pkg.lisp Sat Mar 23 23:02:31 2024 -0400
4.3@@ -10,11 +10,17 @@
4.4
4.5 (defpackage :cry/hotp
4.6 (:nicknames :hotp)
4.7- (:use :cl :std :cry))
4.8+ (:use :cl :std :cry)
4.9+ (:export *digits*
4.10+ *hmac-sha-mode*
4.11+ hotp))
4.12
4.13 (defpackage :cry/totp
4.14 (:nicknames :totp)
4.15- (:use :cl :std :cry))
4.16+ (:use :cl :std :cry/hotp)
4.17+ (:export *time-zero*
4.18+ *time-step-in-seconds*
4.19+ totp))
4.20
4.21 (defpackage :cry/crc64
4.22 (:use :cl)
4.23@@ -54,6 +60,8 @@
4.24 (defclass password () ())
4.25 (defclass password-db (database) ())
4.26 (defclass password-store () ())
4.27+
4.28+;;; Proto
4.29 (defgeneric register-user (user &key store password deadline)
4.30 (:documentation "Register user identified by TOKEN in store specified by STORE. Returns
4.31 the user object and an optionally a confirmation token."))
5.1--- a/lisp/lib/cry/totp.lisp Sat Mar 23 21:28:11 2024 -0400
5.2+++ b/lisp/lib/cry/totp.lisp Sat Mar 23 23:02:31 2024 -0400
5.3@@ -1,6 +1,22 @@
5.4 ;;; crypto/totp.lisp --- Time-Based One-Time Passwords
5.5
5.6+;; see https://github.com/bhyde/cl-one-time-passwords/totp.lisp
5.7+
5.8 ;; RFC 6238
5.9
5.10 ;;; Code:
5.11-(in-package :cry
5.12+(in-package :cry/totp)
5.13+
5.14+(defconstant .unix-epoch-zero. 2208988800)
5.15+ ;; 00:00:00 UTC on 1 January 1970
5.16+ ;; (encode-universal-time 0 0 0 1 1 1970 0)
5.17+ ;; --> 2208988800
5.18+
5.19+(defvar *time-zero* 0) ; aka the unix epoch zero
5.20+(defvar *time-step-in-seconds* 30)
5.21+
5.22+(defmacro time-step (unix-time)
5.23+ `(floor (- ,unix-time *time-zero*) *time-step-in-seconds*))
5.24+
5.25+(defun totp (key-hexstring &optional (offset 0) (time (- (get-universal-time) .unix-epoch-zero. offset)))
5.26+ (hotp key-hexstring (time-step time)))
6.1--- a/lisp/lib/dat/dat.asd Sat Mar 23 21:28:11 2024 -0400
6.2+++ b/lisp/lib/dat/dat.asd Sat Mar 23 23:02:31 2024 -0400
6.3@@ -1,6 +1,6 @@
6.4 (defsystem :dat
6.5 :description "Data formats"
6.6- :depends-on (:cl-ppcre :std :obj)
6.7+ :depends-on (:cl-ppcre :std :obj :png)
6.8 :version "0.1.0"
6.9 :serial t
6.10 :components ((:file "pkg")
8.1--- a/lisp/lib/dat/pkg.lisp Sat Mar 23 21:28:11 2024 -0400
8.2+++ b/lisp/lib/dat/pkg.lisp Sat Mar 23 23:02:31 2024 -0400
8.3@@ -123,5 +123,21 @@
8.4 #:header #:header-type
8.5 #:unknown-event #:status #:data-byte #:dd #:bb #:cc #:nn))
8.6
8.7+(defpackage :dat/qrcode
8.8+ (:nicknames :qrcode)
8.9+ (:use :cl :std :dat/proto)
8.10+ (:export
8.11+ :encode-symbol
8.12+ ;; QR code representation
8.13+ ;; this should be enough to write another backend for QR symbol
8.14+ :qr-symbol
8.15+ :matrix
8.16+ :modules
8.17+ :dark-module-p
8.18+ :read-file-content))
8.19+
8.20+(defpackage :dat/png
8.21+ (:use :cl :std :dat/proto :dat/qrcode :png))
8.22+
8.23 (uiop:define-package :dat
8.24 (:use-reexport :dat/proto :dat/csv :dat/arff :dat/toml :dat/json :dat/sxp :dat/xml :dat/bencode))
9.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
9.2+++ b/lisp/lib/dat/png.lisp Sat Mar 23 23:02:31 2024 -0400
9.3@@ -0,0 +1,57 @@
9.4+;;; dat/png.lisp --- PNG image format
9.5+
9.6+;;
9.7+
9.8+;;; Code:
9.9+(in-package :dat/png)
9.10+
9.11+;;;; Copyright (c) 2011-2014 jnjcc, Yste.org. All rights reserved.
9.12+;;;;
9.13+;;;; png backend for QR code symbol
9.14+
9.15+;; (defun set-color (pngarray x y color)
9.16+;; (setf (aref pngarray x y 0) color)
9.17+;; (setf (aref pngarray x y 1) color)
9.18+;; (setf (aref pngarray x y 2) color))
9.19+
9.20+;; (defun symbol->png (symbol pixsize margin)
9.21+;; "return the qr symbol written into a zpng:png object with PIXSIZE
9.22+;; pixels for each module, and MARGIN pixels on all four sides"
9.23+;; (with-slots (matrix modules) symbol
9.24+;; (let* ((size (+ (* modules pixsize) (* margin 2)))
9.25+;; (qrpng (make-instance 'zpng:png :width size :height size))
9.26+;; (qrarray (zpng:data-array qrpng)))
9.27+;; (dotimes (x size)
9.28+;; (dotimes (y size)
9.29+;; (if (and (<= margin x (- size margin 1))
9.30+;; (<= margin y (- size margin 1)))
9.31+;; (let ((i (floor (- x margin) pixsize))
9.32+;; (j (floor (- y margin) pixsize)))
9.33+;; (if (dark-module-p matrix i j)
9.34+;; (set-color qrarray x y 0)
9.35+;; (set-color qrarray x y 255)))
9.36+;; ;; quiet zone
9.37+;; (set-color qrarray x y 255))))
9.38+;; qrpng)))
9.39+
9.40+;; (defun encode-png (text &key (fpath "qrcode.png") (version 1) (level :level-m)
9.41+;; (mode nil) (pixsize 9) (margin 8))
9.42+;; (let ((symbol (encode-symbol text :version version :level level :mode mode)))
9.43+;; (zpng:write-png (symbol->png symbol pixsize margin) fpath)))
9.44+
9.45+;; (defun encode-png-stream (text stream &key (version 1) (level :level-m)
9.46+;; (mode nil) (pixsize 9) (margin 8))
9.47+;; (let ((symbol (encode-symbol text :version version :level level :mode mode)))
9.48+;; (zpng:write-png-stream (symbol->png symbol pixsize margin) stream)))
9.49+
9.50+;; (defun encode-png-bytes (bytes &key (fpath "kanji.png") (version 1)
9.51+;; (level :level-m) (mode nil) (pixsize 9) (margin 8))
9.52+;; (let ((symbol (encode-symbol-bytes bytes :version version :level level
9.53+;; :mode mode)))
9.54+;; (zpng:write-png (symbol->png symbol pixsize margin) fpath)))
9.55+
9.56+;; (defun encode-png-bytes-stream (bytes stream &key (version 1) (level :level-m)
9.57+;; (mode nil) (pixsize 9) (margin 8))
9.58+;; (let ((symbol (encode-symbol-bytes bytes :version version :level level
9.59+;; :mode mode)))
9.60+;; (zpng:write-png-stream (symbol->png symbol pixsize margin) stream)))
10.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
10.2+++ b/lisp/lib/dat/qrcode.lisp Sat Mar 23 23:02:31 2024 -0400
10.3@@ -0,0 +1,1628 @@
10.4+;;; dat/qrcode.lisp --- QR Code formats
10.5+
10.6+;; see https://github.com/jnjcc/cl-qrencode
10.7+
10.8+;;; Code:
10.9+(in-package :dat/qrcode)
10.10+
10.11+;;;; Copyright (c) 2011-2014 jnjcc, Yste.org. All rights reserved.
10.12+;;;;
10.13+(defun read-file-content (fpath)
10.14+ (with-open-file (fp fpath)
10.15+ (let ((content (make-string (file-length fp))))
10.16+ (read-sequence content fp)
10.17+ content)))
10.18+
10.19+;;;; Galois Field with primitive element 2, as used by Reed-Solomon code
10.20+
10.21+(defclass galois ()
10.22+ ((power :initform nil :initarg :power :reader gf-power
10.23+ :documentation "Galois Field GF(2^POWER)")
10.24+ (prime-poly :initform nil :initarg :ppoly :reader prime-poly
10.25+ :documentation "prime polynomial")
10.26+ (order :initform nil :reader gf-order)
10.27+ (exp-table :initform nil)
10.28+ (log-table :initform nil)))
10.29+
10.30+(defmethod initialize-instance :after ((gf galois) &rest args)
10.31+ (declare (ignore args))
10.32+ (setf (slot-value gf 'order) (ash 1 (slot-value gf 'power)))
10.33+ (let* ((order (gf-order gf))
10.34+ (ppoly (prime-poly gf))
10.35+ ;; 2^0 = 1 && (log 0) = -1
10.36+ (exptab (make-array order :initial-element 1))
10.37+ (logtab (make-array order :initial-element -1)))
10.38+ (do ((i 1 (1+ i)))
10.39+ ((>= i order))
10.40+ (setf (aref exptab i) (* (aref exptab (- i 1)) 2))
10.41+ (when (>= (aref exptab i) order)
10.42+ (setf (aref exptab i)
10.43+ (boole boole-and (- order 1)
10.44+ (boole boole-xor (aref exptab i) ppoly))))
10.45+ (setf (aref logtab (aref exptab i)) i))
10.46+ (setf (aref logtab 1) 0)
10.47+ (setf (slot-value gf 'exp-table) exptab)
10.48+ (setf (slot-value gf 'log-table) logtab)))
10.49+
10.50+;;; value accessor
10.51+(defgeneric gf-exp (gf pow)
10.52+ (:documentation "2^POW under Galois Field GF"))
10.53+(defgeneric gf-log (gf value)
10.54+ (:documentation "VALUE should be within range [0, 2^POW - 1]"))
10.55+
10.56+(defmethod gf-exp ((gf galois) pow)
10.57+ (let* ((sz (- (gf-order gf) 1))
10.58+ (idx (mod pow sz)))
10.59+ (aref (slot-value gf 'exp-table) idx)))
10.60+
10.61+(defmethod gf-log ((gf galois) value)
10.62+ (let* ((sz (gf-order gf))
10.63+ (idx (mod value sz)))
10.64+ (aref (slot-value gf 'log-table) idx)))
10.65+
10.66+;;; Galois Field arithmetic
10.67+(defgeneric gf-add (gf a b))
10.68+(defgeneric gf-subtract (gf a b))
10.69+(defgeneric gf-multiply (gf a b))
10.70+(defgeneric gf-divide (gf a b))
10.71+
10.72+(defmethod gf-add ((gf galois) a b)
10.73+ (boole boole-xor a b))
10.74+
10.75+(defmethod gf-subtract ((gf galois) a b)
10.76+ (boole boole-xor a b))
10.77+
10.78+(defmethod gf-multiply ((gf galois) a b)
10.79+ (let ((sum (+ (gf-log gf a) (gf-log gf b))))
10.80+ (gf-exp gf sum)))
10.81+
10.82+(defmethod gf-divide ((gf galois) a b)
10.83+ (when (= b 0)
10.84+ (error "divide by zero"))
10.85+ (if (= a 0)
10.86+ 0
10.87+ (let ((sub (- (gf-log gf a) (gf-log gf b))))
10.88+ (gf-exp gf sub))))
10.89+
10.90+;;; open-paren at beg of line confuses `slime-compile-defun` which uses
10.91+;;; elisp function `beginning-of-defun`, which in turn involves
10.92+;;; backward-searching open-paren at beg of line
10.93+;;; there seems to be no easy way to fix this problem
10.94+;; with an extra leading '\', docstring is kind of ulgy now, though
10.95+(defmacro with-gf-accessors (accessors gf &body body)
10.96+ "shortcuts for gf-exp & gf-log, usage:
10.97+\(with-gf-accessors ((gfexp gf-exp)) *gf-instance* ...)"
10.98+ `(labels ,(mapcar (lambda (acc-entry)
10.99+ (let ((acc-name (car acc-entry))
10.100+ (method-name (cadr acc-entry)))
10.101+ `(,acc-name (a)
10.102+ (,method-name ,gf a))))
10.103+ accessors)
10.104+ ,@body))
10.105+
10.106+(defmacro with-gf-arithmetics (ariths gf &body body)
10.107+ "shortcuts for gf-add, gf-subtract, gf-multiply & gf-divide, usage:
10.108+\(with-gf-arithmetics ((gf+ gf-add)) *gf-instance* ...)"
10.109+ `(labels ,(mapcar (lambda (arith-entry)
10.110+ (let ((arith-name (car arith-entry))
10.111+ (method-name (cadr arith-entry)))
10.112+ `(,arith-name (a b)
10.113+ (,method-name ,gf a b))))
10.114+ ariths)
10.115+ ,@body))
10.116+
10.117+(defmacro with-gf-shortcuts (accessors ariths gf &body body)
10.118+ "combined with-gf-accessors & with-gf-arithmetics, usage:
10.119+\(with-gf-shortcuts ((gflog gf-log)) ((gf* gf-multiply)) *gf-instance* ...)"
10.120+ `(labels ,(append
10.121+ (mapcar (lambda (acc-entry)
10.122+ (let ((acc-name (car acc-entry))
10.123+ (method-name (cadr acc-entry)))
10.124+ `(,acc-name (a)
10.125+ (,method-name ,gf a))))
10.126+ accessors)
10.127+ (mapcar (lambda (arith-entry)
10.128+ (let ((arith-name (car arith-entry))
10.129+ (method-name (cadr arith-entry)))
10.130+ `(,arith-name (a b)
10.131+ (,method-name ,gf a b))))
10.132+ ariths))
10.133+ ,@body))
10.134+
10.135+;;;; Bose-Chaudhuri-Hocquenghem (BCH) error correction code
10.136+
10.137+;;; Polynomial (using list) arithmetics
10.138+;;; by polynomial list (3 2 1), we mean 3*x^2 + 2*x + 1
10.139+(defun poly-ash (poly s)
10.140+ "shift left POLY by S"
10.141+ (declare (type list poly))
10.142+ (append poly (make-list s :initial-element 0)))
10.143+(defun poly-multiply (poly b &optional (op #'*))
10.144+ "multiply B on every element of POLY using OP"
10.145+ (labels ((mult (elem)
10.146+ (funcall op elem b)))
10.147+ (mapcar #'mult poly)))
10.148+(defun poly-substract (lhs rhs &optional (op #'-))
10.149+ (labels ((sub (elem1 elem2)
10.150+ (funcall op elem1 elem2)))
10.151+ (mapcar #'sub lhs rhs)))
10.152+(defun poly-mod (msg gen rem &optional (sub #'poly-substract) (mul #'poly-multiply))
10.153+ "MSG % GEN, with REM remainders"
10.154+ (labels ((cdrnzero (msg rem)
10.155+ (do ((head msg (cdr head)))
10.156+ ((or (null head) (<= (length head) rem) (/= (car head) 0)) head)
10.157+ head)))
10.158+ (do ((m (poly-ash msg rem) (cdrnzero m rem)))
10.159+ ((<= (length m) rem) m)
10.160+ (let* ((glen (length gen))
10.161+ (sft (- (length m) glen))
10.162+ ;; LEAD coffiecient of message polynomial
10.163+ (lead (car m)))
10.164+ (setf m (funcall sub m (poly-ash (funcall mul gen lead) sft)))))))
10.165+
10.166+(defclass bch-ecc ()
10.167+ ((k :initform nil :initarg :k
10.168+ :documentation "# of data codewords")
10.169+ (ec :initform nil :initarg :ec
10.170+ :documentation "# of error correction codewords")))
10.171+
10.172+(defun bch* (poly b)
10.173+ (poly-multiply poly b))
10.174+(defun bch- (lhs rhs)
10.175+ (labels ((xor (a b)
10.176+ (boole boole-xor a b)))
10.177+ (poly-substract lhs rhs #'xor)))
10.178+(defun bch-xor (lhs rhs)
10.179+ (labels ((xor (a b)
10.180+ (boole boole-xor a b)))
10.181+ (mapcar #'xor lhs rhs)))
10.182+(defun bch% (msg gen rem)
10.183+ (poly-mod msg gen rem #'bch- #'bch*))
10.184+
10.185+(defgeneric bch-ecc (bch msgpoly genpoly)
10.186+ (:documentation "do bch error correction under BCH(K+EC, K)"))
10.187+
10.188+(defmethod bch-ecc ((bch bch-ecc) msg gen)
10.189+ (with-slots (k ec) bch
10.190+ (unless (= (length msg) k)
10.191+ (error "wrong msg length, expect: ~A; got: ~A~%" k (length msg)))
10.192+ (bch% msg gen ec)))
10.193+
10.194+;;; As used by format information ecc & version information ecc respectively
10.195+;;; BCH(15, 5) & BCH(18, 6)
10.196+(let ((fi-ecc (make-instance 'bch-ecc :k 5 :ec 10))
10.197+ ;; format information generator polynomial
10.198+ ;; x^10 + x^8 + x^5 + x^4 + x^2 + x + 1
10.199+ (fi-gpoly '(1 0 1 0 0 1 1 0 1 1 1))
10.200+ (fi-xor '(1 0 1 0 1 0 0 0 0 0 1 0 0 1 0)))
10.201+ (defun format-ecc (level mask-ind)
10.202+ (let ((seq (append (level-indicator level)
10.203+ (mask-pattern-ref mask-ind))))
10.204+ (bch-xor (append seq (bch-ecc fi-ecc seq fi-gpoly))
10.205+ fi-xor))))
10.206+
10.207+(let ((vi-ecc (make-instance 'bch-ecc :k 6 :ec 12))
10.208+ ;; version information generator polynomial
10.209+ ;; x^12 + x^11 + x^10 + x^9 + x^8 + x^5 + x^2 + 1
10.210+ (vi-gpoly '(1 1 1 1 1 0 0 1 0 0 1 0 1)))
10.211+ (defun version-ecc (version)
10.212+ (let ((seq (decimal->bstream version 6)))
10.213+ (append seq (bch-ecc vi-ecc seq vi-gpoly)))))
10.214+
10.215+(defclass rs-ecc ()
10.216+ ((k :initform nil :initarg :k
10.217+ :documentation "# of data codewords")
10.218+ (ec :initform nil :initarg :ec
10.219+ :documentation "# of error correction codewords")
10.220+ (gpoly :initform nil :reader gpoly
10.221+ :documentation "with EC, we calculate generator poly immediately")))
10.222+
10.223+;;; Reed-Solomon code uses GF(2^8) with prime polynomial 285,
10.224+;;; or 1,0001,1101, or (x^8 + x^4 + x^3 + x^2 + 1)
10.225+(let ((gf256 (make-instance 'galois :power 8 :ppoly 285)))
10.226+ ;; Polynomial arithmetics under GF(2^8), as used by Reed-Solomon ecc
10.227+ (defun rs* (poly b)
10.228+ "multiply B on every element of POLY under GF(2^8)"
10.229+ (with-gf-arithmetics ((gf* gf-multiply)) gf256
10.230+ (poly-multiply poly b #'gf*)))
10.231+ (defun rs- (lhs rhs)
10.232+ (with-gf-arithmetics ((gf- gf-subtract)) gf256
10.233+ (poly-substract lhs rhs #'gf-)))
10.234+ (defun rs% (msg gen rem)
10.235+ (poly-mod msg gen rem #'rs- #'rs*))
10.236+
10.237+ (defmethod initialize-instance :after ((rs rs-ecc) &rest args)
10.238+ (declare (ignore args))
10.239+ (setf (slot-value rs 'gpoly) (gen-poly rs)))
10.240+
10.241+ (defgeneric gen-poly (rs))
10.242+ (defmethod gen-poly ((rs rs-ecc))
10.243+ "Generator Polynomial: (x-a^0) * (x-a^1) * ... * (x-a^(ec-1))"
10.244+ (with-slots (ec) rs
10.245+ (let* ((size (+ ec 1))
10.246+ (poly (make-list size :initial-element nil)))
10.247+ (with-gf-shortcuts ((gfexp gf-exp)) ((gf+ gf-add) (gf* gf-multiply)) gf256
10.248+ (setf (nth 0 poly) 1
10.249+ (nth 1 poly) 1)
10.250+ (do ((i 2 (1+ i)))
10.251+ ((> i ec) poly)
10.252+ (setf (nth i poly) 1)
10.253+ (do ((j (- i 1) (1- j)))
10.254+ ((<= j 0))
10.255+ (if (not (= (nth j poly) 0))
10.256+ (setf (nth j poly)
10.257+ (gf+ (nth (- j 1) poly)
10.258+ (gf* (nth j poly) (gfexp (- i 1)))))
10.259+ (setf (nth j poly) (nth (- j 1) poly))))
10.260+ (setf (nth 0 poly) (gf* (nth 0 poly) (gfexp (- i 1))))))
10.261+ (reverse poly))))
10.262+
10.263+ (defgeneric gen-poly-gflog (rs))
10.264+ (defgeneric ecc-poly (rs msg))
10.265+
10.266+ (defmethod gen-poly-gflog ((rs rs-ecc))
10.267+ (with-gf-accessors ((gflog gf-log)) gf256
10.268+ ;; GPOLY already calculated when making new instance
10.269+ (mapcar #'gflog (gpoly rs))))
10.270+
10.271+ (defmethod ecc-poly ((rs rs-ecc) msg-poly)
10.272+ "Error Correction codewords Polynomial for MSG-POLY"
10.273+ (with-slots (k ec gpoly) rs
10.274+ (unless (= (length msg-poly) k)
10.275+ (error "wrong msg-poly length, expect: ~A~%" k))
10.276+ (rs% msg-poly gpoly ec))))
10.277+
10.278+(deftype qr-mode ()
10.279+ '(member :unknown
10.280+ :numeric :alnum :byte :kanji
10.281+ ;; Extended Channel Interpretation, Structured Append, FNC1
10.282+ :eci :structured :fnc1))
10.283+
10.284+(defun mode-indicator (mode)
10.285+ (declare (type qr-mode mode))
10.286+ (case mode
10.287+ (:numeric '(0 0 0 1)) ; "0001"
10.288+ (:alnum '(0 0 1 0)) ; "0010"
10.289+ (:byte '(0 1 0 0)) ; "0100"
10.290+ (:kanji '(1 0 0 0)) ; "1000"
10.291+ (:eci '(0 1 1 1)) ; "0111"
10.292+ (:structured '(0 0 1 1)) ; "0011"
10.293+ (:fnc1 '(0 1 0 1)))) ; FIXME: "0101" & "1001"
10.294+
10.295+(defun terminator (bstream version level)
10.296+ "End of message"
10.297+ (let* ((nbits (length bstream))
10.298+ (diff (- (* (data-words-capacity version level) 8)
10.299+ nbits)))
10.300+ (cond
10.301+ ((< diff 0) (error "you serious about this?!"))
10.302+ ((<= diff 4) (make-list diff :initial-element 0))
10.303+ (t (make-list 4 :initial-element 0)))))
10.304+
10.305+(defun byte-value (mode byte)
10.306+ "BYTE value under MODE"
10.307+ (declare (type qr-mode mode))
10.308+ (case mode
10.309+ (:numeric
10.310+ (and (<= #x30 byte #x39)
10.311+ (- byte #x30)))
10.312+ (:alnum
10.313+ (cond
10.314+ ((<= #x30 byte #x39) (- byte #x30)) ; 0-9
10.315+ ((<= #x41 byte #x5A) (+ (- byte #x41) 10)) ; A-Z
10.316+ ((= byte #x20) 36) ; SP
10.317+ ((= byte #x24) 37) ; $
10.318+ ((= byte #x25) 38) ; %
10.319+ ((= byte #x2A) 39) ; *
10.320+ ((= byte #x2B) 40) ; +
10.321+ ((= byte #x2D) 41) ; -
10.322+ ((= byte #x2E) 42) ; .
10.323+ ((= byte #x2F) 43) ; /
10.324+ ((= byte #x3A) 44) ; :
10.325+ (t nil)))
10.326+ ((:byte :kanji) byte)))
10.327+
10.328+(defun kanji-word-p (word)
10.329+ "(kanji-p, kanji-range: {0, 1})"
10.330+ (cond
10.331+ ((<= #x8140 word #x9ffc) (values t 0))
10.332+ ((<= #xe040 word #xebbf) (values t 1))
10.333+ (t (values nil nil))))
10.334+
10.335+(defun starts-kanji-p (bytes)
10.336+ "(BYTES starts with kanji-p, kanji word value, kanji-range: {0, 1})"
10.337+ (declare (type list bytes))
10.338+ (let* ((first (car bytes))
10.339+ (second (cadr bytes))
10.340+ (word (and second (+ (ash first 8) second))))
10.341+ (if (and first second)
10.342+ (multiple-value-bind (kanji-p range)
10.343+ (kanji-word-p word)
10.344+ (values kanji-p word range))
10.345+ (values nil nil nil))))
10.346+
10.347+(defun xor-subset-of (bytes)
10.348+ "exclusive subset of first unit of BYTES.
10.349+as for unit, one byte for :numeric, :alnum; two bytes for :kanji"
10.350+ (declare (type list bytes))
10.351+ (let* ((first (car bytes)))
10.352+ (cond
10.353+ ((null first) :unknown)
10.354+ ((byte-value :numeric first) :numeric)
10.355+ ((byte-value :alnum first) :alnum)
10.356+ ;; excluding reserved values 80-9F & E0-FF
10.357+ ((and (not (<= #x80 first #x9F))
10.358+ (not (<= #xE0 first #xFF)))
10.359+ :byte)
10.360+ ((starts-kanji-p bytes)
10.361+ :kanji))))
10.362+
10.363+(defclass qr-input ()
10.364+ ((bytes
10.365+ :initform nil :initarg :bytes :reader bytes :type list
10.366+ :documentation "list of bytes to be encoded")
10.367+ (version
10.368+ :initform 1 :initarg :version :reader version
10.369+ :documentation "version of qr symbol, adapted according to BYTES")
10.370+ (ec-level ; cannot be NIL
10.371+ :initform :level-m :initarg :ec-level :reader level :type ecc-level)
10.372+ (mode
10.373+ :initform nil :initarg :mode :reader mode :type (or null qr-mode)
10.374+ :documentation "if supplied, we force all BYTES to be under MODE,
10.375+therefore, unless you know exactly what you are doing, leave this NIL")
10.376+ (cur-byte
10.377+ :initform 0 :accessor cur-byte
10.378+ :documentation "index of BYTES during data analysis")
10.379+ (segments
10.380+ :initform nil :accessor segments :type list
10.381+ :documentation
10.382+ "list of list, of the form ((:mode1 byte ...) (:mode2 byte ...) ...)")
10.383+ (bstream
10.384+ :initform nil :reader bstream :type list
10.385+ :documentation "list of 0-1 values after encoding SEGMENTS")
10.386+ (blocks
10.387+ :initform nil :reader blocks :type list
10.388+ :documentation "list of list, of the form ((codeword ...) (codeword ...) ...)
10.389+after converting BSTREAM to codewords")
10.390+ (ecc-blocks ; error correction blocks
10.391+ :initform nil :reader ecc-blocks :type list
10.392+ :documentation "list of list, ec codewords corresponding to BLOCKS")
10.393+ (msg-codewords
10.394+ :initform nil :reader message :type list
10.395+ :documentation "list of codewords from BLOCKS & ECC-BLOCKS,
10.396+interleaving if neccessary")
10.397+ (matrix
10.398+ :initform nil :accessor matrix
10.399+ :documentation "raw QR code symbol (without masking) as matrix")))
10.400+
10.401+(defmethod initialize-instance :after ((input qr-input) &rest args)
10.402+ (declare (ignore args))
10.403+ (validate-and-analysis input))
10.404+
10.405+;;; 0) Data analysis
10.406+(defgeneric validate-and-analysis (input)
10.407+ (:documentation "adapt VERSION according to BYTES, and fill SEGMENTS slot"))
10.408+;;; 1) Data encoding
10.409+(defgeneric data-encoding (input)
10.410+ (:documentation "encode SEGMENTS into BSTREAM slot"))
10.411+;;; 2) Error correction coding
10.412+(defgeneric ec-coding (input)
10.413+ (:documentation "split BSTREAM into BLOCKS, do rs-ecc, and fill ECC-BLOCKS"))
10.414+;;; 3) Structure final message
10.415+(defgeneric structure-message (input)
10.416+ (:documentation "interleaving BLOCKS and ECC-BLOCKS into MSG-CODEWORDS"))
10.417+;;; 4) Codeword placement in matrix, a.k.a, raw QR code symbol
10.418+(defgeneric module-placement (input)
10.419+ (:documentation "write MSG-CODEWORDS into the raw (without masking) MATRIX"))
10.420+;;; 5) Data masking & Format information
10.421+(defgeneric data-masking (input)
10.422+ (:documentation "mask MATRIX with best pattern, generate the final symbol"))
10.423+
10.424+(defgeneric data-analysis (input)
10.425+ (:documentation "BYTES -> SEGMETS, switch bewteen modes as necessary to
10.426+achieve the most efficient conversion of data"))
10.427+(defgeneric redo-data-analysis (input)
10.428+ (:documentation "VERSION changed, reset CUR-BYTE and redo data analysis"))
10.429+(defgeneric analyse-byte-mode (input &optional seg))
10.430+(defgeneric analyse-alnum-mode (input &optional seg))
10.431+(defgeneric analyse-numeric-mode (input &optional seg))
10.432+(defgeneric analyse-kanji-mode (input &optional seg))
10.433+(defgeneric append-cur-byte (input &optional seg)
10.434+ (:documentation "append CUR-BYTE of BYTES into SEGMENTS"))
10.435+(defun mode-analyse-func (mode)
10.436+ "put CUR-BYTE into MODE, and then look at following BYTES for new segment"
10.437+ (case mode
10.438+ (:byte #'analyse-byte-mode)
10.439+ (:alnum #'analyse-alnum-mode)
10.440+ (:numeric #'analyse-numeric-mode)
10.441+ (:kanji #'analyse-kanji-mode)))
10.442+
10.443+(defmethod data-analysis ((input qr-input))
10.444+ (with-slots (mode cur-byte segments) input
10.445+ (when mode ; MODE supplied
10.446+ (let ((seg (append (list mode) (bytes input))))
10.447+ (setf cur-byte (length (bytes input)))
10.448+ (setf segments (append segments (list seg))))
10.449+ (return-from data-analysis)))
10.450+ (with-slots (bytes version segments) input
10.451+ (let ((init-mode (select-init-mode bytes version)))
10.452+ (funcall (mode-analyse-func init-mode) input))))
10.453+
10.454+(defmethod redo-data-analysis ((input qr-input))
10.455+ (with-slots (cur-byte segments) input
10.456+ (setf cur-byte 0)
10.457+ (setf segments nil)
10.458+ (data-analysis input)))
10.459+
10.460+(defun select-init-mode (bytes version)
10.461+ "optimization of bitstream length: select initial mode"
10.462+ (declare (type list bytes))
10.463+ (let ((init-xor (xor-subset-of bytes)))
10.464+ (case init-xor
10.465+ (:byte :byte)
10.466+ (:kanji
10.467+ (case (xor-subset-of (nthcdr 2 bytes))
10.468+ ((:numeric :alnum) :kanji)
10.469+ (:byte
10.470+ (let ((nunits (ecase (version-range version)
10.471+ ((0 1) 5)
10.472+ (2 6))))
10.473+ (if (every-unit-matches (nthcdr 3 bytes) 2 nunits :kanji)
10.474+ :byte
10.475+ :kanji)))
10.476+ (otherwise :kanji)))
10.477+ (:alnum
10.478+ (let ((nunits (ecase (version-range version)
10.479+ (0 6) (1 7) (2 8))))
10.480+ ;; number of units (characters) match :alnum, followed by a :byte unit
10.481+ (multiple-value-bind (n last-mode) (nunits-matches (cdr bytes) :alnum)
10.482+ (if (and (< n nunits) (eq last-mode :byte))
10.483+ :byte
10.484+ :alnum))))
10.485+ (:numeric
10.486+ (let ((nbunits (ecase (version-range version)
10.487+ ((0 1) 4) (2 5)))
10.488+ (naunits (ecase (version-range version)
10.489+ (0 7) (1 8) (2 9))))
10.490+ (multiple-value-bind (n last-mode) (nunits-matches (cdr bytes) :numeric)
10.491+ (if (and (< n nbunits) (eq last-mode :byte))
10.492+ :byte
10.493+ (if (and (< n naunits) (eq last-mode :alnum))
10.494+ :alnum
10.495+ :numeric))))))))
10.496+
10.497+;;; UNIT: character under a certain mode,
10.498+;;; a byte under :numeric :alnum & :byte, or a byte-pair under :kanji
10.499+(defun every-unit-matches (bytes usize nunits mode)
10.500+ "if every unit of USZIE bytes (at most NUNITS unit) within BYTES matches MODE"
10.501+ (declare (type list bytes) (type qr-mode mode))
10.502+ (when (>= (length bytes) (* usize nunits))
10.503+ (dotimes (i nunits)
10.504+ (let ((b (nthcdr (* usize i) bytes)))
10.505+ (unless (eq (xor-subset-of b) mode)
10.506+ (return-from every-unit-matches nil))))
10.507+ (return-from every-unit-matches t)))
10.508+
10.509+(defun nunits-matches (bytes mode)
10.510+ "(number of units that matches MODE, and mode for the first unmatched unit)"
10.511+ (declare (type list bytes) (type qr-mode mode))
10.512+ (let ((usize (ecase mode
10.513+ ((:byte :alnum :numeric) 1)
10.514+ ;; as for :kanji, 2 bytes forms a single unit
10.515+ (:kanji 2)))
10.516+ (nunits 0))
10.517+ (do ((b bytes (nthcdr usize b)))
10.518+ ((or (null b)
10.519+ (not (eq (xor-subset-of b) mode)))
10.520+ (values nunits (xor-subset-of b)))
10.521+ (incf nunits))))
10.522+
10.523+(defmethod analyse-byte-mode ((input qr-input) &optional (seg '(:byte)))
10.524+ (declare (type list seg))
10.525+ (setf seg (append-cur-byte input seg))
10.526+ (unless seg
10.527+ (return-from analyse-byte-mode))
10.528+ (with-slots (bytes cur-byte version segments) input
10.529+ (let* ((range (version-range version))
10.530+ (nkunits (ecase range ; number of :kanji units before more :byte
10.531+ (0 9) (1 12) (2 13)))
10.532+ (nanuits (ecase range ; number of :alnum units before more :byte
10.533+ (0 11) (1 15) (2 16)))
10.534+ (nmunits1 (ecase range ; number of :numeric units before more :byte
10.535+ (0 6) (1 8) (2 9)))
10.536+ (nmunits2 (ecase range ; number of :numeric units before more :alnum
10.537+ (0 6) (1 7) (2 8)))
10.538+ (switch-mode nil))
10.539+ (multiple-value-bind (nmatches last-mode)
10.540+ (nunits-matches (nthcdr cur-byte bytes) :kanji)
10.541+ (and (>= nmatches nkunits) (eq last-mode :byte)
10.542+ (setf switch-mode :kanji)))
10.543+ (unless switch-mode
10.544+ (multiple-value-bind (nmatches last-mode)
10.545+ (nunits-matches (nthcdr cur-byte bytes) :alnum)
10.546+ (and (>= nmatches nanuits) (eq last-mode :byte)
10.547+ (setf switch-mode :alnum))))
10.548+ (unless switch-mode
10.549+ (multiple-value-bind (nmatches last-mode)
10.550+ (nunits-matches (nthcdr cur-byte bytes) :numeric)
10.551+ (case last-mode
10.552+ (:byte (and (>= nmatches nmunits1)
10.553+ (setf switch-mode :numeric)))
10.554+ (:alnum (and (>= nmatches nmunits2)
10.555+ (setf switch-mode :numeric))))))
10.556+ (if switch-mode
10.557+ (progn
10.558+ ;; current segment finished, add a new SWITCH-MODE segment
10.559+ (setf segments (append segments (list seg)))
10.560+ (setf seg (list switch-mode)))
10.561+ (setf switch-mode :byte))
10.562+ (funcall (mode-analyse-func switch-mode) input seg))))
10.563+
10.564+(defmethod analyse-alnum-mode ((input qr-input) &optional (seg '(:alnum)))
10.565+ (declare (type list seg))
10.566+ (setf seg (append-cur-byte input seg))
10.567+ (unless seg
10.568+ (return-from analyse-alnum-mode))
10.569+ (with-slots (bytes cur-byte version segments) input
10.570+ (let ((nmunits (ecase (version-range version)
10.571+ (0 13) (1 15) (2 17)))
10.572+ (switch-mode nil))
10.573+ (when (>= (nunits-matches (nthcdr cur-byte bytes) :kanji) 1)
10.574+ (setf switch-mode :kanji))
10.575+ (unless switch-mode
10.576+ (when (>= (nunits-matches (nthcdr cur-byte bytes) :byte) 1)
10.577+ (setf switch-mode :byte)))
10.578+ (unless switch-mode
10.579+ (multiple-value-bind (nmatches last-mode)
10.580+ (nunits-matches (nthcdr cur-byte bytes) :numeric)
10.581+ (and (>= nmatches nmunits) (eq last-mode :alnum)
10.582+ (setf switch-mode :numeric))))
10.583+ (if switch-mode
10.584+ (progn
10.585+ (setf segments (append segments (list seg)))
10.586+ (setf seg (list switch-mode)))
10.587+ (setf switch-mode :alnum))
10.588+ (funcall (mode-analyse-func switch-mode) input seg))))
10.589+
10.590+(defmethod analyse-numeric-mode ((input qr-input) &optional (seg '(:numeric)))
10.591+ (declare (type list seg))
10.592+ (setf seg (append-cur-byte input seg))
10.593+ (unless seg
10.594+ (return-from analyse-numeric-mode))
10.595+ (with-slots (bytes cur-byte version segments) input
10.596+ (let ((switch-mode nil))
10.597+ (when (>= (nunits-matches (nthcdr cur-byte bytes) :kanji) 1)
10.598+ (setf switch-mode :kanji))
10.599+ (unless switch-mode
10.600+ (when (>= (nunits-matches (nthcdr cur-byte bytes) :byte) 1)
10.601+ (setf switch-mode :byte)))
10.602+ (unless switch-mode
10.603+ (when (>= (nunits-matches (nthcdr cur-byte bytes) :alnum) 1)
10.604+ (setf switch-mode :alnum)))
10.605+ (if switch-mode
10.606+ (progn
10.607+ (setf segments (append segments (list seg)))
10.608+ (setf seg (list switch-mode)))
10.609+ (setf switch-mode :numeric))
10.610+ (funcall (mode-analyse-func switch-mode) input seg))))
10.611+
10.612+(defmethod append-cur-byte ((input qr-input) &optional seg)
10.613+ "if CUR-BYTE is the last byte, return nil"
10.614+ (declare (type list seg))
10.615+ (with-slots (bytes cur-byte segments) input
10.616+ (setf seg (append seg (list (nth cur-byte bytes))))
10.617+ (incf cur-byte)
10.618+ (when (>= cur-byte (length bytes))
10.619+ (setf segments (append segments (list seg)))
10.620+ (setf seg nil))
10.621+ (return-from append-cur-byte seg)))
10.622+
10.623+(defmethod analyse-kanji-mode ((input qr-input) &optional (seg '(:kanji)))
10.624+ (declare (type list seg))
10.625+ (with-slots (bytes cur-byte segments) input
10.626+ (setf seg (append seg (nthcdr cur-byte bytes)))
10.627+ (setf cur-byte (length bytes))
10.628+ (setf segments (append segments (list seg)))))
10.629+
10.630+(defmethod validate-and-analysis ((input qr-input))
10.631+ (with-slots ((level ec-level) segments) input
10.632+ (unless (<= 1 (version input) 40)
10.633+ (error "version ~A out of bounds" (version input)))
10.634+ (do ((prev -1))
10.635+ ((<= (version input) prev))
10.636+ (setf prev (version input))
10.637+ (redo-data-analysis input)
10.638+ (labels ((seg-bstream-len (seg)
10.639+ (segment-bstream-length seg (version input))))
10.640+ (let* ((blen (reduce #'+ (mapcar #'seg-bstream-len segments)
10.641+ :initial-value 0))
10.642+ (min-v (minimum-version prev (ceiling blen 8) level)))
10.643+ (if min-v
10.644+ (setf (slot-value input 'version) min-v)
10.645+ (error "no version to hold ~A bytes" (ceiling blen 8))))))))
10.646+
10.647+(defmethod data-encoding ((input qr-input))
10.648+ (with-slots (version (level ec-level) segments) input
10.649+ (labels ((seg->bstream (seg)
10.650+ (segment->bstream seg version)))
10.651+ (let* ((bs (reduce #'append (mapcar #'seg->bstream segments)
10.652+ :initial-value nil))
10.653+ (tt (terminator bs version level))
10.654+ ;; connect bit streams in all segment, with terminator appended
10.655+ (bstream (append bs tt)))
10.656+ ;; add padding bits
10.657+ (setf bstream (append bstream (padding-bits bstream)))
10.658+ ;; add pad codewords, finishes data encoding
10.659+ (setf (slot-value input 'bstream)
10.660+ (append bstream
10.661+ (pad-codewords bstream version level)))))))
10.662+
10.663+(defmethod ec-coding ((input qr-input))
10.664+ (with-slots (version (level ec-level) bstream) input
10.665+ (let ((codewords (bstream->codewords bstream))
10.666+ (blocks nil)
10.667+ (ecc-blocks nil)
10.668+ ;; RS error correction obj for blk1 & blk2
10.669+ (rs1 nil)
10.670+ (rs2 nil))
10.671+ (multiple-value-bind (ecc-num blk1 data1 blk2 data2)
10.672+ (ecc-block-nums version level)
10.673+ (when (> blk1 0)
10.674+ (setf rs1 (make-instance 'rs-ecc :k data1 :ec ecc-num)))
10.675+ (when (> blk2 0)
10.676+ (setf rs2 (make-instance 'rs-ecc :k data2 :ec ecc-num)))
10.677+ (dotimes (i blk1)
10.678+ (setf blocks
10.679+ (append blocks (list (subseq codewords 0 data1))))
10.680+ (setf codewords (nthcdr data1 codewords)))
10.681+ (dotimes (i blk2)
10.682+ (setf blocks
10.683+ (append blocks (list (subseq codewords 0 data2))))
10.684+ (setf codewords (nthcdr data2 codewords)))
10.685+ (dotimes (i blk1)
10.686+ (setf ecc-blocks
10.687+ (append ecc-blocks (list (ecc-poly rs1 (nth i blocks))))))
10.688+ (dotimes (i blk2)
10.689+ (setf ecc-blocks
10.690+ (append ecc-blocks (list (ecc-poly rs2 (nth (+ i blk1) blocks))))))
10.691+ (setf (slot-value input 'blocks) blocks)
10.692+ (setf (slot-value input 'ecc-blocks) ecc-blocks)))))
10.693+
10.694+(defmethod structure-message ((input qr-input))
10.695+ (with-slots (version (level ec-level) blocks ecc-blocks) input
10.696+ (let ((final nil))
10.697+ (multiple-value-bind (ecc-num blk1 data1 blk2 data2)
10.698+ (ecc-block-nums version level)
10.699+ (declare (ignore ecc-num))
10.700+ (setf (slot-value input 'msg-codewords)
10.701+ (append final
10.702+ ;; interleave data blocks, data blocks may differ in length
10.703+ (take-data-in-turn blocks blk1 data1 blk2 data2)
10.704+ ;; we know error correction blocks are of the same length
10.705+ (take-in-turn ecc-blocks)))))))
10.706+
10.707+(defmethod module-placement ((input qr-input))
10.708+ (setf (matrix input) (make-matrix (version input)))
10.709+ (with-slots (version msg-codewords matrix) input
10.710+ ;; Function pattern placement
10.711+ (function-patterns matrix version)
10.712+ ;; Symbol character placement
10.713+ (let ((rbits (remainder-bits version))
10.714+ (bstream nil))
10.715+ (labels ((dec->byte (codeword)
10.716+ (decimal->bstream codeword 8)))
10.717+ (setf bstream (append (reduce #'append (mapcar #'dec->byte msg-codewords))
10.718+ ;; data capacity of _symbol_ does not divide by 8
10.719+ (make-list rbits :initial-element 0))))
10.720+ (symbol-character bstream matrix version))))
10.721+
10.722+(defmethod data-masking ((input qr-input))
10.723+ "(masked matrix, mask pattern reference)"
10.724+ (with-slots (version (level ec-level) matrix) input
10.725+ (let ((modules (matrix-modules version)))
10.726+ (multiple-value-bind (masked indicator)
10.727+ (choose-masking matrix modules level)
10.728+ (values masked (mask-pattern-ref indicator))))))
10.729+
10.730+(defun decimal->bstream (dec nbits)
10.731+ "using NBITS bits to encode decimal DEC"
10.732+ (let ((bstream nil))
10.733+ (dotimes (i nbits)
10.734+ (if (logbitp i dec)
10.735+ (push 1 bstream)
10.736+ (push 0 bstream)))
10.737+ bstream))
10.738+(defun bstream->decimal (bstream nbits)
10.739+ (declare (type list bstream))
10.740+ (let ((nbits (min nbits (length bstream)))
10.741+ (dec 0))
10.742+ (dotimes (i nbits)
10.743+ (setf dec (+ (* dec 2) (nth i bstream))))
10.744+ dec))
10.745+
10.746+;;; :numeric mode
10.747+(defun group->decimal (values ndigits)
10.748+ "digit groups of length NDIGITS (1, 2 or 3) to decimal"
10.749+ (declare (type list values))
10.750+ (case ndigits
10.751+ (1 (nth 0 values))
10.752+ (2 (+ (* (nth 0 values) 10) (nth 1 values)))
10.753+ (3 (+ (* (nth 0 values) 100) (* (nth 1 values) 10) (nth 2 values)))))
10.754+(defun final-digit-bits (n)
10.755+ "the final one or two digits are converted to 4 or 7 bits respectively"
10.756+ (case n
10.757+ (0 0) (1 4) (2 7)))
10.758+(defun numeric->bstream (bytes)
10.759+ (declare (type list bytes))
10.760+ (labels ((num-value (byte)
10.761+ (byte-value :numeric byte)))
10.762+ (let ((values (mapcar #'num-value bytes))
10.763+ (bstream nil))
10.764+ (do ((v values (nthcdr 3 v)))
10.765+ ((null v) bstream)
10.766+ (case (length v)
10.767+ (1 ; only 1 digits left
10.768+ (setf bstream
10.769+ (append bstream (decimal->bstream (group->decimal v 1)
10.770+ (final-digit-bits 1)))))
10.771+ (2 ; only 2 digits left
10.772+ (setf bstream
10.773+ (append bstream (decimal->bstream (group->decimal v 2)
10.774+ (final-digit-bits 2)))))
10.775+ (otherwise ; at least 3 digits left
10.776+ (setf bstream
10.777+ (append bstream
10.778+ (decimal->bstream (group->decimal v 3) 10)))))))))
10.779+
10.780+;;; :alnum mode
10.781+(defun pair->decimal (values num)
10.782+ "alnum pairs of length NUM (1 or 2) to decimal"
10.783+ (declare (type list values))
10.784+ (case num
10.785+ (1 (nth 0 values))
10.786+ (2 (+ (* (nth 0 values) 45) (nth 1 values)))))
10.787+(defun alnum->bstream (bytes)
10.788+ (declare (type list bytes))
10.789+ (labels ((alnum-value (byte)
10.790+ (byte-value :alnum byte)))
10.791+ (let ((values (mapcar #'alnum-value bytes))
10.792+ (bstream nil))
10.793+ (do ((v values (nthcdr 2 v)))
10.794+ ((null v) bstream)
10.795+ (case (length v)
10.796+ (1 ; only 1 alnum left
10.797+ (setf bstream
10.798+ (append bstream
10.799+ (decimal->bstream (pair->decimal v 1) 6))))
10.800+ (otherwise ; at least 2 alnum left
10.801+ (setf bstream
10.802+ (append bstream
10.803+ (decimal->bstream (pair->decimal v 2) 11)))))))))
10.804+
10.805+;;; :byte mode
10.806+(defun byte->bstream (bytes)
10.807+ (declare (type list bytes))
10.808+ (labels ((join (prev cur)
10.809+ (append prev (decimal->bstream (byte-value :byte cur) 8))))
10.810+ (reduce #'join bytes :initial-value nil)))
10.811+
10.812+;;; :kanji mode
10.813+(defun kanji->decimal (word range)
10.814+ (let ((subtractor (ecase range
10.815+ (0 #x8140)
10.816+ (1 #xc140))))
10.817+ (decf word subtractor)
10.818+ (setf word (+ (* (ash word -8) #xc0)
10.819+ (boole boole-and word #xff)))))
10.820+(defun kanji->bstream (bytes)
10.821+ (declare (type list bytes))
10.822+ (labels ((kanji-value (byte)
10.823+ (byte-value :kanji byte)))
10.824+ (let ((values (mapcar #'kanji-value bytes))
10.825+ (delta 1)
10.826+ (bstream nil))
10.827+ (do ((v values (nthcdr delta v)))
10.828+ ((null v) bstream)
10.829+ (case (length v)
10.830+ (1 ; only 1 byte left
10.831+ (setf bstream
10.832+ (append bstream (decimal->bstream (car v) 13)))
10.833+ (setf delta 1))
10.834+ (otherwise ; at least 2 bytes left
10.835+ (multiple-value-bind (kanji-p word range) (starts-kanji-p v)
10.836+ (if kanji-p
10.837+ (progn
10.838+ (setf bstream
10.839+ (append bstream
10.840+ (decimal->bstream (kanji->decimal word range)
10.841+ 13)))
10.842+ (setf delta 2))
10.843+ (progn
10.844+ (setf bstream
10.845+ (append bstream (decimal->bstream (car v) 13)))
10.846+ (setf delta 1))))))))))
10.847+
10.848+;;; :eci mode
10.849+(defun eci->bstream (bytes)
10.850+ "TODO"
10.851+ (declare (ignore bytes))
10.852+ (error "eci->bstream: TODO..."))
10.853+
10.854+(defun bstream-trans-func (mode)
10.855+ (case mode
10.856+ (:numeric #'numeric->bstream)
10.857+ (:alnum #'alnum->bstream)
10.858+ (:byte #'byte->bstream)
10.859+ (:kanji #'kanji->bstream)))
10.860+
10.861+(defun kanji-bytes-length (bytes)
10.862+ (declare (type list bytes))
10.863+ (let ((step 1)
10.864+ (len 0))
10.865+ (do ((b bytes (nthcdr step b)))
10.866+ ((null b) len)
10.867+ (if (starts-kanji-p b)
10.868+ (setf step 2)
10.869+ (setf step 1))
10.870+ (incf len))))
10.871+
10.872+(defun bytes-length (bytes mode)
10.873+ "number of data characters under MODE"
10.874+ (declare (type list bytes) (type qr-mode mode))
10.875+ (case mode
10.876+ ((:numeric :alnum :byte) (length bytes))
10.877+ (:kanji (kanji-bytes-length bytes))))
10.878+
10.879+(defun segment-bstream-length (segment version)
10.880+ "bit stream length of SEGMENT (:mode b0 b1 ...) under VERSION"
10.881+ (declare (type list segment))
10.882+ (let* ((mode (car segment))
10.883+ (bytes (cdr segment))
10.884+ (m 4)
10.885+ (c (char-count-bits version mode))
10.886+ (d (bytes-length bytes mode))
10.887+ (r 0))
10.888+ ;; M = number of bits in mode indicator
10.889+ ;; C = number of bits in character count indicator
10.890+ ;; D = number of input data characters
10.891+ (case mode
10.892+ (:numeric
10.893+ (setf r (final-digit-bits (mod d 3)))
10.894+ ;; B = M + C + 10 * (D / 3) + R
10.895+ (+ m c (* 10 (floor d 3)) r))
10.896+ (:alnum
10.897+ (setf r (mod d 2))
10.898+ ;; B = M + C + 11 * (D / 2) + 6 * (D % 2)
10.899+ (+ m c (* 11 (floor d 2)) (* 6 r)))
10.900+ (:byte
10.901+ ;; B = M + C + 8 * D
10.902+ (+ m c (* 8 d)))
10.903+ (:kanji
10.904+ ;; B = M + C + 13 * D
10.905+ (+ m c (* 13 d))))))
10.906+
10.907+(defun segment->bstream (segment version)
10.908+ "SEGMENT (:mode b0 b1 ...) to bit stream under VERSION"
10.909+ (declare (type list segment))
10.910+ (let* ((mode (car segment))
10.911+ (bytes (cdr segment))
10.912+ (len (bytes-length bytes mode))
10.913+ (n (char-count-bits version mode))
10.914+ (bstream nil))
10.915+ (append bstream (mode-indicator mode)
10.916+ (decimal->bstream len n) ; character count indicator
10.917+ (funcall (bstream-trans-func mode) bytes))))
10.918+
10.919+(defun padding-bits (bstream)
10.920+ "add padding bits so that BSTREAM ends at a codeword boundary"
10.921+ (multiple-value-bind (quot rem) (ceiling (length bstream) 8)
10.922+ (declare (ignore quot))
10.923+ (make-list (- rem) :initial-element 0)))
10.924+
10.925+(defun pad-codewords (bstream version level)
10.926+ "add pad codewords (after adding padding-bits) to fill data codeword capacity"
10.927+ (let ((pad-words '((1 1 1 0 1 1 0 0)
10.928+ (0 0 0 1 0 0 0 1)))
10.929+ (pad-len (- (data-words-capacity version level)
10.930+ (/ (length bstream) 8)))
10.931+ (ret nil))
10.932+ (dotimes (i pad-len)
10.933+ (setf ret (append ret (nth (mod i 2) pad-words))))
10.934+ ret))
10.935+
10.936+(defun bstream->codewords (bstream)
10.937+ "convert bstream into codewords, as coefficients of the terms of a polynomial"
10.938+ (do ((b bstream (nthcdr 8 b))
10.939+ (codewords nil))
10.940+ ((null b) codewords)
10.941+ (setf codewords (append codewords (list (bstream->decimal b 8))))))
10.942+
10.943+(defun take-in-turn (blks)
10.944+ "taking codewords from each block (bound by minimum length) in turn"
10.945+ (reduce #'append (apply #'mapcar #'list blks)))
10.946+
10.947+(defun take-data-in-turn (blocks blk1 data1 blk2 data2)
10.948+ "taking data words from each block (might have different length) in turn"
10.949+ (let ((data-final nil)
10.950+ (left-blks nil))
10.951+ (setf data-final (take-in-turn blocks))
10.952+ (cond
10.953+ ((or (= blk1 0) (= blk2 0))
10.954+ ;; only one kind of block exists
10.955+ (setf left-blks nil))
10.956+ ((> data1 data2)
10.957+ ;; block 1 has more elements left
10.958+ (setf left-blks (mapcar #'(lambda (blk)
10.959+ (nthcdr data2 blk))
10.960+ (subseq blocks 0 blk1))))
10.961+ ((> data2 data1)
10.962+ ;; block 2 has more elements left
10.963+ (setf left-blks (mapcar #'(lambda (blk)
10.964+ (nthcdr data1 blk))
10.965+ (subseq blocks blk1 (+ blk1 blk2))))))
10.966+ (if left-blks
10.967+ (append data-final (take-in-turn left-blks))
10.968+ data-final)))
10.969+
10.970+(deftype module-color ()
10.971+ ":RAW, nothing has been done to this module; :RESERVE, format info reserve module
10.972+:FLIGHT/:FDARK, function pattern light/dark module; :LIGHT/:DARK, data modules"
10.973+ '(member :raw :flight :fdark :reserve :light :dark))
10.974+
10.975+(defun same-color-p (color1 color2)
10.976+ "during QR symbol evaluation, :fdark & :dark are considered to be same"
10.977+ (case color1
10.978+ ((:flight :light) (or (eq color2 :flight) (eq color2 :light)))
10.979+ ((:fdark :dark) (or (eq color2 :fdark) (eq color2 :fdark)))
10.980+ (otherwise (eq color1 color2))))
10.981+
10.982+(defun raw-module-p (matrix i j)
10.983+ "nothing has been done to MATRIX[I, J]"
10.984+ (eq (aref matrix i j) :raw))
10.985+
10.986+(defun make-modules-matrix (modules &optional (init :raw))
10.987+ "make a raw matrix with MODULES * MODULES elements"
10.988+ (make-array `(,modules ,modules) :initial-element init))
10.989+
10.990+(defun make-matrix (version &optional (init :raw))
10.991+ "make a raw matrix according to VERSION"
10.992+ (let ((n (matrix-modules version)))
10.993+ (make-modules-matrix n init)))
10.994+
10.995+(defun paint-square (matrix x y n &optional (color :fdark))
10.996+ "Paint a square of size N*N starting from upleft (X, Y) in MATRIX to COLOR"
10.997+ (let ((maxx (+ x n -1))
10.998+ (maxy (+ y n -1)))
10.999+ (loop for i from x to maxx do
10.1000+ (loop for j from y to maxy do
10.1001+ (setf (aref matrix i j) color))))
10.1002+ matrix)
10.1003+
10.1004+;;; Function Patterns
10.1005+(defun function-patterns (matrix version)
10.1006+ (let ((modules (matrix-modules version)))
10.1007+ (finder-patterns matrix modules)
10.1008+ (separator matrix modules)
10.1009+ (timing-patterns matrix modules)
10.1010+ (alignment-patterns matrix version))
10.1011+ matrix)
10.1012+;; a) Finder Patterns: fixed position in matrix
10.1013+(defun one-finder-pattern (matrix x y)
10.1014+ "Paint one finder pattern starting from upleft (X, Y)"
10.1015+ (paint-square matrix x y 7 :fdark)
10.1016+ (paint-square matrix (+ x 1) (+ y 1) 5 :flight)
10.1017+ (paint-square matrix (+ x 2) (+ y 2) 3 :fdark))
10.1018+(defun finder-patterns (matrix modules)
10.1019+ ;; top-left finder pattern
10.1020+ (one-finder-pattern matrix 0 0)
10.1021+ ;; top-right finder pattern
10.1022+ (one-finder-pattern matrix (- modules 7) 0)
10.1023+ ;; bottom-left finder pattern
10.1024+ (one-finder-pattern matrix 0 (- modules 7)))
10.1025+
10.1026+;; b) Separator: fixed position in matrix
10.1027+(defun separator (matrix modules)
10.1028+ (dotimes (j 8)
10.1029+ ;; top-left horizontal separator
10.1030+ (setf (aref matrix 7 j) :flight)
10.1031+ ;; top-right horizontal separator
10.1032+ (setf (aref matrix 7 (- modules j 1)) :flight)
10.1033+ ;; bottom-left horizontal separator
10.1034+ (setf (aref matrix (- modules 8) j) :flight))
10.1035+ (dotimes (i 8)
10.1036+ ;; top-left vertical separator
10.1037+ (setf (aref matrix i 7) :flight)
10.1038+ ;; bottom-left vertical separator
10.1039+ (setf (aref matrix (- modules i 1) 7) :flight)
10.1040+ ;; top-right vertical separator
10.1041+ (setf (aref matrix i (- modules 8)) :flight))
10.1042+ matrix)
10.1043+
10.1044+;; c) Timing patterns
10.1045+(defun timing-patterns (matrix modules)
10.1046+ (let ((color :fdark))
10.1047+ (loop for idx from 8 to (- modules 9) do
10.1048+ (if (evenp idx)
10.1049+ (setf color :fdark)
10.1050+ (setf color :flight))
10.1051+ ;; Horizontal
10.1052+ (setf (aref matrix 6 idx) color)
10.1053+ ;; Vertical
10.1054+ (setf (aref matrix idx 6) color)))
10.1055+ matrix)
10.1056+
10.1057+;; d) Alignment Patterns: varies between versions
10.1058+;; may overlap timing patterns, modules coincide with that of timing patterns
10.1059+(defun one-align-pattern (matrix x y)
10.1060+ "Paint one alignment pattern centered at (X, Y)"
10.1061+ (paint-square matrix (- x 2) (- y 2) 5 :fdark)
10.1062+ (paint-square matrix (- x 1) (- y 1) 3 :flight)
10.1063+ (paint-square matrix x y 1 :fdark))
10.1064+(defun alignment-patterns (matrix version)
10.1065+ (dolist (center (align-centers version) matrix)
10.1066+ (one-align-pattern matrix (first center) (second center))))
10.1067+
10.1068+;;; Encoding Region
10.1069+(defun symbol-character (bstream matrix version)
10.1070+ (let ((modules (matrix-modules version)))
10.1071+ (reserve-information matrix version)
10.1072+ (bstream-placement bstream matrix modules))
10.1073+ matrix)
10.1074+;; reserve format information & version information
10.1075+(defun reserve-information (matrix version)
10.1076+ (let ((modules (matrix-modules version)))
10.1077+ ;; format information...
10.1078+ ;; top-left & top-right horizontal
10.1079+ (dotimes (j 8)
10.1080+ (when (raw-module-p matrix 8 j)
10.1081+ (setf (aref matrix 8 j) :reserve))
10.1082+ (setf (aref matrix 8 (- modules j 1)) :reserve))
10.1083+ (setf (aref matrix 8 8) :reserve)
10.1084+ ;; top-left & bottom-left vertical
10.1085+ (dotimes (i 8)
10.1086+ (when (raw-module-p matrix i 8)
10.1087+ (setf (aref matrix i 8) :reserve))
10.1088+ (setf (aref matrix (- modules i 1) 8) :reserve))
10.1089+ ;; dark module...
10.1090+ (setf (aref matrix (- modules 8) 8) :fdark)
10.1091+
10.1092+ ;; version information for version 7-40
10.1093+ (when (>= version 7)
10.1094+ (version-information matrix modules version))))
10.1095+
10.1096+(defun paint-fcolor-bit (matrix i j bit)
10.1097+ "Paint function pattern color for MATRIX[I, J] according to BIT of {0, 1}"
10.1098+ (setf (aref matrix i j) (case bit
10.1099+ (0 :flight) (1 :fdark))))
10.1100+(defun version-information (matrix modules version)
10.1101+ "version information placement on two blocks of modules:
10.1102+bottom-left 3*6 block: [modules-11, modules-9] * [0, 5]
10.1103+top-right 6*3 block: [0, 5] * [modules-11, modules-9]"
10.1104+ (assert (>= version 7))
10.1105+ (let ((vib (version-ecc version))
10.1106+ (i (- modules 9))
10.1107+ (start (- modules 9))
10.1108+ (bound (- modules 11))
10.1109+ (j 5))
10.1110+ (dolist (bit vib matrix)
10.1111+ (paint-fcolor-bit matrix i j bit)
10.1112+ (paint-fcolor-bit matrix j i bit)
10.1113+ (if (>= (- i 1) bound)
10.1114+ (decf i)
10.1115+ (progn
10.1116+ (decf j)
10.1117+ (setf i start))))))
10.1118+
10.1119+;; Symbol character placement
10.1120+(defun paint-color-bit (matrix i j bit)
10.1121+ "Paint data color for MATRIX[I, J] according to BIT of {0, 1}"
10.1122+ (setf (aref matrix i j) (case bit
10.1123+ (0 :light) (1 :dark))))
10.1124+(defun bstream-placement (bstream matrix modules)
10.1125+ "2X4 module block for a regular symbol character. Regard the interleaved
10.1126+codeword sequence as a single bit stream, which is placed in the two module
10.1127+wide columns, alternately in the right and left modules, moving upwards or
10.1128+downwards according to DIRECTION, skipping function patterns, changing DIRECTION
10.1129+at the top or bottom of the symbol. The only exception is that no block should
10.1130+ever overlap the vertical timing pattern."
10.1131+ (let ((i (- modules 1))
10.1132+ (j (- modules 1))
10.1133+ ;; -1: upwards, +1: downwards
10.1134+ (direction -1)
10.1135+ (len (length bstream)))
10.1136+ (do ((idx 0))
10.1137+ ((>= idx len) matrix)
10.1138+ (when (raw-module-p matrix i j)
10.1139+ (paint-color-bit matrix i j (nth idx bstream))
10.1140+ (incf idx))
10.1141+ (when (and (>= (- j 1) 0)
10.1142+ (raw-module-p matrix i (- j 1)))
10.1143+ ;; try left module
10.1144+ (paint-color-bit matrix i (- j 1) (nth idx bstream))
10.1145+ (incf idx))
10.1146+ (if (< -1 (+ i direction) modules)
10.1147+ (incf i direction)
10.1148+ (progn
10.1149+ ;; reverse direction
10.1150+ (setf direction (- direction))
10.1151+ (if (= j 8)
10.1152+ ;; vertical timing pattern reached, the next block starts
10.1153+ ;; to the left of it
10.1154+ (decf j 3)
10.1155+ (decf j 2)))))))
10.1156+
10.1157+;;; format information, during and after masking
10.1158+(defun format-information (matrix modules level mask-ind)
10.1159+ ;; format information bistream
10.1160+ (let ((fib (format-ecc level mask-ind))
10.1161+ (darks 0)
10.1162+ (idx 0)
10.1163+ (idx2 0))
10.1164+ (setf darks (count-if #'(lambda (elem) (= elem 1)) fib))
10.1165+ ;; horizontal 14 ~ 8
10.1166+ (loop for j from 0 to 7 do
10.1167+ (when (eq (aref matrix 8 j) :reserve)
10.1168+ (paint-fcolor-bit matrix 8 j (nth idx fib))
10.1169+ (incf idx)))
10.1170+ ;; vertical 14 ~ 8
10.1171+ (loop for i from (- modules 1) downto (- modules 7) do
10.1172+ (paint-fcolor-bit matrix i 8 (nth idx2 fib))
10.1173+ (incf idx2))
10.1174+ ;; horizontal 7 - 0
10.1175+ (loop for j from (- modules 8) to (- modules 1) do
10.1176+ (paint-fcolor-bit matrix 8 j (nth idx fib))
10.1177+ (incf idx))
10.1178+ ;; vertical 7 - 0
10.1179+ (loop for i from 8 downto 0 do
10.1180+ (when (eq (aref matrix i 8) :reserve)
10.1181+ (paint-fcolor-bit matrix i 8 (nth idx2 fib))
10.1182+ (incf idx2)))
10.1183+ (values matrix darks)))
10.1184+
10.1185+;;; only encoding region modules (excluding format information) are masked
10.1186+(defun encoding-module-p (matrix i j)
10.1187+ "modules belong to encoding region, excluding format & version information"
10.1188+ (or (eq (aref matrix i j) :light)
10.1189+ (eq (aref matrix i j) :dark)))
10.1190+(defun non-mask-module-p (matrix i j)
10.1191+ (not (encoding-module-p matrix i j)))
10.1192+(defun reverse-module-color (matrix i j)
10.1193+ (case (aref matrix i j)
10.1194+ (:dark :light) (:light :dark)))
10.1195+
10.1196+;;; all modules are evaluated:
10.1197+;;; there should be only :dark :light :fdark :flight modules left by now
10.1198+(defun dark-module-p (matrix i j)
10.1199+ (or (eq (aref matrix i j) :fdark)
10.1200+ (eq (aref matrix i j) :dark)))
10.1201+
10.1202+(defun copy-and-mask (matrix modules level mask-ind)
10.1203+ "make a new matrix and mask using MASK-IND for later evaluation"
10.1204+ (let ((ret (make-modules-matrix modules))
10.1205+ (mask-p (mask-condition mask-ind))
10.1206+ (darks 0))
10.1207+ (dotimes (i modules)
10.1208+ (dotimes (j modules)
10.1209+ (cond
10.1210+ ((non-mask-module-p matrix i j)
10.1211+ (setf (aref ret i j) (aref matrix i j)))
10.1212+ ((funcall mask-p i j) ; need mask
10.1213+ (setf (aref ret i j) (reverse-module-color matrix i j)))
10.1214+ (t
10.1215+ (setf (aref ret i j) (aref matrix i j))))
10.1216+ (when (dark-module-p ret i j)
10.1217+ (incf darks))))
10.1218+ (multiple-value-bind (dummy fi-darks)
10.1219+ (format-information ret modules level mask-ind)
10.1220+ (declare (ignore dummy))
10.1221+ ;; add format information dark modules
10.1222+ (values ret (+ darks fi-darks)))))
10.1223+
10.1224+(defun mask-matrix (matrix modules level mask-ind)
10.1225+ "do not evaluate, just go ahead and mask MATRIX using MASK-IND mask pattern"
10.1226+ (let ((mask-p (mask-condition mask-ind)))
10.1227+ (dotimes (i modules)
10.1228+ (dotimes (j modules)
10.1229+ (and (encoding-module-p matrix i j)
10.1230+ (funcall mask-p i j)
10.1231+ (setf (aref matrix i j) (reverse-module-color matrix i j)))))
10.1232+ ;; paint format information
10.1233+ (format-information matrix modules level mask-ind)
10.1234+ matrix))
10.1235+
10.1236+(defun choose-masking (matrix modules level)
10.1237+ "mask and evaluate using each mask pattern, choose the best mask result"
10.1238+ (let ((n4 10)
10.1239+ (best-matrix nil)
10.1240+ (mask-indicator nil)
10.1241+ (min-penalty nil)
10.1242+ (square (* modules modules))
10.1243+ (cur-penalty 0))
10.1244+ (dotimes (i *mask-pattern-num*)
10.1245+ (multiple-value-bind (cur-matrix darks)
10.1246+ (copy-and-mask matrix modules level i)
10.1247+ ;; feature 4: proportion of dark modules in entire symbol
10.1248+ (let ((bratio (/ (+ (* darks 200) square) square 2)))
10.1249+ (setf cur-penalty (* (/ (abs (- bratio 50)) 5) n4)))
10.1250+ (incf cur-penalty (evaluate-feature-123 cur-matrix modules))
10.1251+ (when (or (null min-penalty)
10.1252+ (< cur-penalty min-penalty))
10.1253+ (setf min-penalty cur-penalty
10.1254+ mask-indicator i
10.1255+ best-matrix cur-matrix))))
10.1256+ (values best-matrix mask-indicator)))
10.1257+
10.1258+;;; feature 1 & 2 & 3
10.1259+(defun evaluate-feature-123 (matrix modules)
10.1260+ (let ((penalty 0))
10.1261+ (incf penalty (evaluate-feature-2 matrix modules))
10.1262+ (dotimes (col modules)
10.1263+ (let ((rlength (calc-run-length matrix modules col)))
10.1264+ (incf penalty (evaluate-feature-1 rlength))
10.1265+ (incf penalty (evaluate-feature-3 rlength))))
10.1266+ (dotimes (row modules)
10.1267+ (let ((rlength (calc-run-length matrix modules row :col)))
10.1268+ (incf penalty (evaluate-feature-1 rlength))
10.1269+ (incf penalty (evaluate-feature-3 rlength))))
10.1270+ penalty))
10.1271+
10.1272+(defun calc-run-length (matrix modules num &optional (direction :row))
10.1273+ "list of number of adjacent modules in same color"
10.1274+ (let ((rlength nil)
10.1275+ (ridx 0))
10.1276+ (labels ((get-elem (idx)
10.1277+ (case direction
10.1278+ (:row (aref matrix num idx))
10.1279+ (:col (aref matrix idx num))))
10.1280+ (add-to-list (list elem)
10.1281+ (append list (list elem))))
10.1282+ ;; we make sure (NTH 1 rlength) is for dark module
10.1283+ (when (same-color-p (get-elem 0) :dark)
10.1284+ (setf rlength (add-to-list rlength -1)
10.1285+ ridx 1))
10.1286+ (setf rlength (add-to-list rlength 1))
10.1287+
10.1288+ (loop for i from 1 to (- modules 1) do
10.1289+ (if (same-color-p (get-elem i) (get-elem (- i 1)))
10.1290+ (incf (nth ridx rlength))
10.1291+ (progn
10.1292+ (incf ridx)
10.1293+ (setf rlength (add-to-list rlength 1)))))
10.1294+ rlength)))
10.1295+
10.1296+(defun evaluate-feature-1 (rlength)
10.1297+ "(5 + i) adjacent modules in row/column in same color. (N1 + i) points, N1 = 3"
10.1298+ (let ((n1 3)
10.1299+ (penalty 0))
10.1300+ (dolist (sz rlength penalty)
10.1301+ (when (> sz 5)
10.1302+ (incf penalty (+ n1 sz -5))))))
10.1303+
10.1304+(defun evaluate-feature-3 (rlength)
10.1305+ "1:1:3:1:1 ration (dark:light:dark:light:dark) pattern in row/column,
10.1306+preceded or followed by light area 4 modules wide. N3 points, N3 = 40"
10.1307+ (let ((n3 40)
10.1308+ (len (length rlength))
10.1309+ (penalty 0))
10.1310+ (do ((i 3 (+ i 2)))
10.1311+ ((>= i (- len 2)) penalty)
10.1312+ (when (and (= (mod i 2) 1) ; for dark module
10.1313+ (= (mod (nth i rlength) 3) 0)
10.1314+ (let ((fact (floor (nth i rlength) 3)))
10.1315+ ;; 1:1:3:1:1
10.1316+ (when (= fact
10.1317+ (nth (- i 2) rlength)
10.1318+ (nth (- i 1) rlength)
10.1319+ (nth (+ i 1) rlength)
10.1320+ (nth (+ i 2) rlength))
10.1321+ (cond
10.1322+ ((<= (- i 3) 0) (incf penalty n3))
10.1323+ ((>= (+ i 4) len) (incf penalty n3))
10.1324+ ((>= (nth (- i 3) rlength) (* 4 fact)) (incf penalty n3))
10.1325+ ((>= (nth (+ i 3) rlength) (* 4 fact)) (incf penalty n3))))))))))
10.1326+
10.1327+(defun evaluate-feature-2 (matrix modules)
10.1328+ "block m * n of modules in same color. N2 * (m-1) * (n-1) points, N2=3"
10.1329+ (let ((n2 3)
10.1330+ (penalty 0)
10.1331+ (bcount 0))
10.1332+ (dotimes (i (- modules 1) penalty)
10.1333+ (dotimes (j (- modules 1))
10.1334+ (when (dark-module-p matrix i j)
10.1335+ (incf bcount))
10.1336+ (when (dark-module-p matrix (+ i 1) j)
10.1337+ (incf bcount))
10.1338+ (when (dark-module-p matrix i (+ j 1))
10.1339+ (incf bcount))
10.1340+ (when (dark-module-p matrix (+ i 1) (+ j 1))
10.1341+ (incf bcount))
10.1342+ (when (or (= bcount 0) (= bcount 4))
10.1343+ (incf penalty n2))))))
10.1344+
10.1345+(defclass qr-symbol ()
10.1346+ ((matrix :initform nil :initarg :matrix :reader matrix
10.1347+ :documentation "qr code symbol as matrix")
10.1348+ (modules :initform nil :initarg :modules :reader modules
10.1349+ :documentation "qr code symbol modules")))
10.1350+
10.1351+(defmethod print-object ((symbol qr-symbol) stream)
10.1352+ (fresh-line stream)
10.1353+ (with-slots (matrix modules) symbol
10.1354+ (format stream "qr symbol ~A x ~A:~%" modules modules)
10.1355+ (dotimes (i modules)
10.1356+ (dotimes (j modules)
10.1357+ (if (dark-module-p matrix i j)
10.1358+ (format stream "1 ")
10.1359+ (format stream "0 ")))
10.1360+ (format stream "~%"))))
10.1361+
10.1362+;;; FIXME: other encodings???
10.1363+(defun ascii->bytes (text)
10.1364+ (map 'list #'char-code text))
10.1365+
10.1366+(defun bytes->input (bytes version level mode)
10.1367+ (setf version (min (max version 1) 40))
10.1368+ (let ((input (make-instance 'qr-input :bytes bytes :version version
10.1369+ :ec-level level :mode mode)))
10.1370+ (data-encoding input)
10.1371+ (ec-coding input)
10.1372+ (structure-message input)
10.1373+ (module-placement input)
10.1374+ input))
10.1375+
10.1376+(defun input->symbol (input)
10.1377+ "encode qr symbol from a qr-input"
10.1378+ (multiple-value-bind (matrix mask-ref)
10.1379+ (data-masking input)
10.1380+ (declare (ignore mask-ref))
10.1381+ (let ((modules (matrix-modules (version input))))
10.1382+ (make-instance 'qr-symbol :matrix matrix :modules modules))))
10.1383+
10.1384+(defun encode-symbol-bytes (bytes &key (version 1) (level :level-m) (mode nil))
10.1385+ "encode final qr symbol from BYTES list"
10.1386+ (let ((input (bytes->input bytes version level mode)))
10.1387+ (log:debug! (format nil "version: ~A; segments: ~A~%" (version input)
10.1388+ (segments input)))
10.1389+ (input->symbol input)))
10.1390+
10.1391+;;;-----------------------------------------------------------------------------
10.1392+;;; One Ring to Rule Them All, One Ring to Find Them,
10.1393+;;; One Ring to Bring Them All and In the Darkness Blind Them:
10.1394+;;; This function wraps all we need.
10.1395+;;;-----------------------------------------------------------------------------
10.1396+;; (sdebug :dbg-input)
10.1397+(defun encode-symbol (text &key (version 1) (level :level-m) (mode nil))
10.1398+ "encode final qr symbol, unless you know what you are doing, leave MODE NIL"
10.1399+ (let ((bytes (ascii->bytes text)))
10.1400+ (encode-symbol-bytes bytes :version version :level level :mode mode)))
10.1401+
10.1402+;;; Table 1 - Codeword capacity of all versions of QR Code 2005
10.1403+;;; excluding Micro QR Code, varies between version
10.1404+(defvar *codeword-capacity-table*
10.1405+ #2A((-1 -1 -1 -1 -1 -1) ; 0, no such version
10.1406+ (21 202 31 208 26 0) (25 235 31 359 44 7)
10.1407+ (29 243 31 567 70 7) (33 251 31 807 100 7)
10.1408+ (37 259 31 1079 134 7) (41 267 31 1383 172 7)
10.1409+ (45 390 67 1568 196 0) (49 398 67 1936 242 0)
10.1410+ (53 406 67 2336 292 0) (57 414 67 2768 346 0) ; Version 10
10.1411+ (61 422 67 3232 404 0) (65 430 67 3728 466 0)
10.1412+ (69 438 67 4256 532 0) (73 611 67 4651 581 3)
10.1413+ (77 619 67 5243 655 3) (81 627 67 5867 733 3)
10.1414+ (85 635 67 6523 815 3) (89 643 67 7211 901 3)
10.1415+ (93 651 67 7931 991 3) (97 659 67 8683 1085 3) ; Version 20
10.1416+ (101 882 67 9252 1156 4) (105 890 67 10068 1258 4)
10.1417+ (109 898 67 10916 1364 4) (113 906 67 11796 1474 4)
10.1418+ (117 914 67 12708 1588 4) (121 922 67 13652 1706 4)
10.1419+ (125 930 67 14628 1828 4) (129 1203 67 15371 1921 3)
10.1420+ (133 1211 67 16411 2051 3) (137 1219 67 17483 2185 3) ; Version 30
10.1421+ (141 1227 67 18587 2323 3) (145 1235 67 19723 2465 3)
10.1422+ (149 1243 67 20891 2611 3) (153 1251 67 22091 2761 3)
10.1423+ (157 1574 67 23008 2876 0) (161 1582 67 24272 3034 0)
10.1424+ (165 1590 67 25568 3196 0) (169 1598 67 26896 3362 0)
10.1425+ (173 1606 67 28256 3532 0) (177 1614 67 29648 3706 0)) ; Version 40
10.1426+ "Number of modules (as version increases, 4 modules added) A | Function pattern
10.1427+modules B | Format and Version information modules C | Data modules (A^2-B-C) |
10.1428+Data capacity codewords (bytes, including ecc codewords) | Remainder bits.")
10.1429+(defun codeword-capacity (version)
10.1430+ "codeword: data word + ecc word"
10.1431+ (aref *codeword-capacity-table* version 4))
10.1432+(defun matrix-modules (version)
10.1433+ (aref *codeword-capacity-table* version 0))
10.1434+(defun remainder-bits (version)
10.1435+ (aref *codeword-capacity-table* version 5))
10.1436+
10.1437+(defun mode->index (mode)
10.1438+ (case mode
10.1439+ (:numeric 0)
10.1440+ (:alnum 1)
10.1441+ (:byte 2)
10.1442+ (:kanji 3)))
10.1443+
10.1444+(deftype ecc-level ()
10.1445+ '(member :level-l :level-m :level-q :level-h))
10.1446+(defun level->index (level)
10.1447+ (case level
10.1448+ (:level-l 0)
10.1449+ (:level-m 1)
10.1450+ (:level-q 2)
10.1451+ (:level-h 3)))
10.1452+
10.1453+;;; (Part I of) Table 9 - Number of Error Correction Codewords (bytes)
10.1454+;;; varies between version and level
10.1455+(defvar *ecc-codewords-table*
10.1456+ ;; (:level-l :level-m :level-q :level-h)
10.1457+ #2A((-1 -1 -1 -1) ;; 0, no such version
10.1458+ (7 10 13 17) (10 16 22 28) (15 26 36 44)
10.1459+ (20 36 52 64) (26 48 72 88) (36 64 96 112)
10.1460+ (40 72 108 130) (48 88 132 156) (60 110 160 192)
10.1461+ (72 130 192 224) (80 150 224 264) (96 176 260 308)
10.1462+ (104 198 288 352) (120 216 320 384) (132 240 360 432)
10.1463+ (144 280 408 480) (168 308 448 532) (180 338 504 588)
10.1464+ (196 364 546 650) (224 416 600 700) (224 442 644 750)
10.1465+ (252 476 690 816) (270 504 750 900) (300 560 810 960)
10.1466+ (312 588 870 1050) (336 644 952 1110) (360 700 1020 1200)
10.1467+ (390 728 1050 1260) (420 784 1140 1350) (450 812 1200 1440)
10.1468+ (480 868 1290 1530) (510 924 1350 1620) (540 980 1440 1710)
10.1469+ (570 1036 1530 1800) (570 1064 1590 1890) (600 1120 1680 1980)
10.1470+ (630 1204 1770 2100) (660 1260 1860 2220) (720 1316 1950 2310)
10.1471+ (750 1372 2040 2430))) ;; version 1 ~ 40
10.1472+(defun ecc-words-capacity (version level)
10.1473+ (aref *ecc-codewords-table* version (level->index level)))
10.1474+(defun data-words-capacity (version level)
10.1475+ (- (codeword-capacity version) (ecc-words-capacity version level)))
10.1476+
10.1477+;;; (Part II of) Table 9 - Error Correction blocks
10.1478+;;; varies between version and level
10.1479+(defvar *ecc-blocks*
10.1480+ ;; (version, level) =>
10.1481+ ;; (# of ec codewords for each blk, # of blk 1, # of data words for blk 1,
10.1482+ ;; # of blk 2, # of data words for blk 2)
10.1483+ ;; :level-l :level-m :level-q :level-h
10.1484+ #3A(((0 0 0 0 0) (0 0 0 0 0) (0 0 0 0 0) (0 0 0 0 0)) ; no such version
10.1485+ ((7 1 19 0 0) (10 1 16 0 0) (13 1 13 0 0) (17 1 9 0 0)) ; Version 1
10.1486+ ((10 1 34 0 0) (16 1 28 0 0) (22 1 22 0 0) (28 1 16 0 0))
10.1487+ ((15 1 55 0 0) (26 1 44 0 0) (18 2 17 0 0) (22 2 13 0 0))
10.1488+ ((20 1 80 0 0) (18 2 32 0 0) (26 2 24 0 0) (16 4 9 0 0))
10.1489+ ((26 1 108 0 0) (24 2 43 0 0) (18 2 15 2 16) (22 2 11 2 12)) ; Version 5
10.1490+ ((18 2 68 0 0) (16 4 27 0 0) (24 4 19 0 0) (28 4 15 0 0))
10.1491+ ((20 2 78 0 0) (18 4 31 0 0) (18 2 14 4 15) (26 4 13 1 14))
10.1492+ ((24 2 97 0 0) (22 2 38 2 39) (22 4 18 2 19) (26 4 14 2 15))
10.1493+ ((30 2 116 0 0) (22 3 36 2 37) (20 4 16 4 17) (24 4 12 4 13))
10.1494+ ((18 2 68 2 69) (26 4 43 1 44) (24 6 19 2 20) (28 6 15 2 16)) ; Version 10
10.1495+ ((20 4 81 0 0) (30 1 50 4 51) (28 4 22 4 23) (24 3 12 8 13))
10.1496+ ((24 2 92 2 93) (22 6 36 2 37) (26 4 20 6 21) (28 7 14 4 15))
10.1497+ ((26 4 107 0 0) (22 8 37 1 38) (24 8 20 4 21) (22 12 11 4 12))
10.1498+ ((30 3 115 1 116) (24 4 40 5 41) (20 11 16 5 17) (24 11 12 5 13))
10.1499+ ((22 5 87 1 88) (24 5 41 5 42) (30 5 24 7 25) (24 11 12 7 13)) ; Version 15
10.1500+ ((24 5 98 1 99) (28 7 45 3 46) (24 15 19 2 20) (30 3 15 13 16))
10.1501+ ((28 1 107 5 108) (28 10 46 1 47) (28 1 22 15 23) (28 2 14 17 15))
10.1502+ ((30 5 120 1 121) (26 9 43 4 44) (28 17 22 1 23) (28 2 14 19 15))
10.1503+ ((28 3 113 4 114) (26 3 44 11 45) (26 17 21 4 22) (26 9 13 16 14))
10.1504+ ((28 3 107 5 108) (26 3 41 13 42) (30 15 24 5 25) (28 15 15 10 16)) ; Version 20
10.1505+ ((28 4 116 4 117) (26 17 42 0 0) (28 17 22 6 23) (30 19 16 6 17))
10.1506+ ((28 2 111 7 112) (28 17 46 0 0) (30 7 24 16 25) (24 34 13 0 0))
10.1507+ ((30 4 121 5 122) (28 4 47 14 48) (30 11 24 14 25) (30 16 15 14 16))
10.1508+ ((30 6 117 4 118) (28 6 45 14 46) (30 11 24 16 25) (30 30 16 2 17))
10.1509+ ((26 8 106 4 107) (28 8 47 13 48) (30 7 24 22 25) (30 22 15 13 16)) ; Version 25
10.1510+ ((28 10 114 2 115) (28 19 46 4 47) (28 28 22 6 23) (30 33 16 4 17))
10.1511+ ((30 8 122 4 123) (28 22 45 3 46) (30 8 23 26 24) (30 12 15 28 16))
10.1512+ ((30 3 117 10 118) (28 3 45 23 46) (30 4 24 31 25) (30 11 15 31 16))
10.1513+ ((30 7 116 7 117) (28 21 45 7 46) (30 1 23 37 24) (30 19 15 26 16))
10.1514+ ((30 5 115 10 116) (28 19 47 10 48) (30 15 24 25 25) (30 23 15 25 16)) ; Version 30
10.1515+ ((30 13 115 3 116) (28 2 46 29 47) (30 42 24 1 25) (30 23 15 28 16))
10.1516+ ((30 17 115 0 0) (28 10 46 23 47) (30 10 24 35 25) (30 19 15 35 16))
10.1517+ ((30 17 115 1 116) (28 14 46 21 47) (30 29 24 19 25) (30 11 15 46 16))
10.1518+ ((30 13 115 6 116) (28 14 46 23 47) (30 44 24 7 25) (30 59 16 1 17))
10.1519+ ((30 12 121 7 122) (28 12 47 26 48) (30 39 24 14 25) (30 22 15 41 16)) ; Version 35
10.1520+ ((30 6 121 14 122) (28 6 47 34 48) (30 46 24 10 25) (30 2 15 64 16))
10.1521+ ((30 17 122 4 123) (28 29 46 14 47) (30 49 24 10 25) (30 24 15 46 16))
10.1522+ ((30 4 122 18 123) (28 13 46 32 47) (30 48 24 14 25) (30 42 15 32 16))
10.1523+ ((30 20 117 4 118) (28 40 47 7 48) (30 43 24 22 25) (30 10 15 67 16))
10.1524+ ((30 19 118 6 119) (28 18 47 31 48) (30 34 24 34 25) (30 20 15 61 16)) ; Version 40
10.1525+ ))
10.1526+(defun ecc-block-nums (version level)
10.1527+ "# of ec codewords for each blk, # of blk 1, # of data words for blk 1, ..."
10.1528+ (let ((lidx (level->index level)))
10.1529+ (values (aref *ecc-blocks* version lidx 0)
10.1530+ (aref *ecc-blocks* version lidx 1)
10.1531+ (aref *ecc-blocks* version lidx 2)
10.1532+ (aref *ecc-blocks* version lidx 3)
10.1533+ (aref *ecc-blocks* version lidx 4))))
10.1534+
10.1535+(defun minimum-version (init-version nbytes level)
10.1536+ "minimum version that can hold NBYTES data words, or INIT-VERSION if bigger"
10.1537+ (do ((v init-version (1+ v)))
10.1538+ ((> v 40) nil)
10.1539+ (when (>= (data-words-capacity v level) nbytes)
10.1540+ (return-from minimum-version v))))
10.1541+
10.1542+(defun version-range (version)
10.1543+ (cond
10.1544+ ((<= 1 version 9) 0)
10.1545+ ((<= 10 version 26) 1)
10.1546+ ((<= 27 version 40) 2)))
10.1547+
10.1548+;;; Table 3 - Number of bits in character count indicator for QR Code 2005
10.1549+(defvar *char-count-indicator*
10.1550+ ;; :numeric :alnum :byte :kanji
10.1551+ #2A((10 9 8 8) ; version-range 0
10.1552+ (12 11 16 10) ; version-range 1
10.1553+ (14 13 16 12))) ; version-range 2
10.1554+(defun char-count-bits (version mode)
10.1555+ (let ((i (version-range version))
10.1556+ (j (mode->index mode)))
10.1557+ (aref *char-count-indicator* i j)))
10.1558+
10.1559+;;; Table E.1 - Row/column coordinates of center modules of alignment patterns
10.1560+;;; varies between versions
10.1561+(defvar *align-coord-table*
10.1562+ #2A((0 ()) ; 0, no such version
10.1563+ (0 ()) (1 (6 18)) (1 (6 22))
10.1564+ (1 (6 26)) (1 (6 30)) (1 (6 34))
10.1565+ (6 (6 22 38)) (6 (6 24 42)) (6 (6 26 46))
10.1566+ (6 (6 28 50)) (6 (6 30 54)) (6 (6 32 58))
10.1567+ (6 (6 34 62)) (13 (6 26 46 66)) (13 (6 26 48 70))
10.1568+ (13 (6 26 50 74)) (13 (6 30 54 78)) (13 (6 30 56 82))
10.1569+ (13 (6 30 58 86)) (13 (6 34 62 90)) (22 (6 28 50 72 94))
10.1570+ (22 (6 26 50 74 98)) (22 (6 30 54 78 102)) (22 (6 28 54 80 106))
10.1571+ (22 (6 32 58 84 110)) (22 (6 30 58 86 114)) (22 (6 34 62 90 118))
10.1572+ (33 (6 26 50 74 98 122)) (33 (6 30 54 78 102 126)) (33 (6 26 52 78 104 130))
10.1573+ (33 (6 30 56 82 108 134)) (33 (6 34 60 86 112 138)) (33 (6 30 58 86 114 142))
10.1574+ (33 (6 34 62 90 118 146)) (46 (6 30 54 78 102 126 150)) (46 (6 24 50 76 102 128 154))
10.1575+ (46 (6 28 54 80 106 132 158)) (46 (6 32 58 84 110 136 162)) (46 (6 26 54 82 110 138 166))
10.1576+ (46 (6 30 58 86 114 142 170)))
10.1577+ "# of Alignment Patterns, row/column coordinates of center modules.")
10.1578+(defun valid-center-p (x y modules)
10.1579+ "The alignment center module is not in Finder Patterns."
10.1580+ (not (or (and (<= 0 x 8) (<= 0 y 8)) ; upleft finder pattern
10.1581+ (and (<= 0 x 8)
10.1582+ (<= (- modules 8) y (- modules 1))) ; upright finder pattern
10.1583+ (and (<= (- modules 8) x (- modules 1))
10.1584+ (<= 0 y 8)))))
10.1585+(defun align-centers (version)
10.1586+ "list of all valid alignment pattern center modules under VERSION"
10.1587+ (let* ((modules (matrix-modules version))
10.1588+ (coords (aref *align-coord-table* version 1))
10.1589+ (len (length coords))
10.1590+ (centers nil))
10.1591+ (dotimes (i len)
10.1592+ (loop for j from i to (- len 1) do
10.1593+ (let ((x (nth i coords))
10.1594+ (y (nth j coords)))
10.1595+ (when (valid-center-p x y modules)
10.1596+ (push (list x y) centers))
10.1597+ (unless (= x y)
10.1598+ (when (valid-center-p y x modules)
10.1599+ (push (list y x) centers))))))
10.1600+ centers))
10.1601+
10.1602+(defvar *mask-pattern-num* 8)
10.1603+(defun mask-condition (indicator)
10.1604+ (lambda (i j)
10.1605+ (case indicator
10.1606+ ;; (i + j) mod 2 == 0
10.1607+ (0 (= (mod (+ i j) 2) 0))
10.1608+ ;; i mod 2 == 0
10.1609+ (1 (= (mod i 2) 0))
10.1610+ ;; j mod 3 == 0
10.1611+ (2 (= (mod j 3) 0))
10.1612+ ;; (i + j) mod 3 == 0
10.1613+ (3 (= (mod (+ i j) 3) 0))
10.1614+ ;; ((i/2) + (j/3)) mod 2 == 0
10.1615+ (4 (= (mod (+ (floor i 2) (floor j 3)) 2) 0))
10.1616+ ;; (i*j) mod 2 + (i*j) mod 3 == 0
10.1617+ (5 (= (+ (mod (* i j) 2) (mod (* i j) 3)) 0))
10.1618+ ;; ((i*j) mod 2 + (i*j) mod 3)) mod 2 == 0
10.1619+ (6 (= (mod (+ (mod (* i j) 2) (mod (* i j) 3)) 2) 0))
10.1620+ ;; ((i+j) mod 2 + (i*j) mod 3)) mod 2 == 0
10.1621+ (7 (= (mod (+ (mod (+ i j) 2) (mod (* i j) 3)) 2) 0)))))
10.1622+
10.1623+(defvar *ecc-level-indicator* #((0 1) (0 0) (1 1) (1 0))
10.1624+ ":level-l :level-m :level-q :level-h")
10.1625+(defun level-indicator (level)
10.1626+ (aref *ecc-level-indicator* (level->index level)))
10.1627+(defvar *mask-pattern-reference*
10.1628+ #((0 0 0) (0 0 1) (0 1 0) (0 1 1)
10.1629+ (1 0 0) (1 0 1) (1 1 0) (1 1 1)))
10.1630+(defun mask-pattern-ref (ind)
10.1631+ (aref *mask-pattern-reference* ind))
