Coverage report: /home/ellis/comp/core/lib/dat/qrcode.lisp

Kind	Covered	All	%
expression	82	3050	2.7
branch	4	250	1.6

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;; dat/qrcode.lisp --- QR Code formats

2

3

;; see https://github.com/jnjcc/cl-qrencode

4

5

6

7

;;; Code:

8

(in-package :dat/qrcode)

9

10

11

(defun read-file-content (fpath)

12

(with-open-file (fp fpath)

13

(let ((content (make-string (file-length fp))))

14

(read-sequence content fp)

15

content)))

16

17

;;;; Galois Field with primitive element 2, as used by Reed-Solomon code

18

(defclass galois ()

19

((power :initform nil :initarg :power :reader gf-power

20

:documentation "Galois Field GF(2^POWER)")

21

(prime-poly :initform nil :initarg :ppoly :reader prime-poly

22

:documentation "prime polynomial")

23

(order :initform nil :reader gf-order)

24

(exp-table :initform nil)

25

(log-table :initform nil)))

26

27

(defmethod initialize-instance :after ((gf galois) &rest args)

28

(declare (ignore args))

29

(setf (slot-value gf 'order) (ash 1 (slot-value gf 'power)))

30

(let* ((order (gf-order gf))

31

(ppoly (prime-poly gf))

32

;; 2^0 = 1 && (log 0) = -1

33

(exptab (make-array order :initial-element 1))

34

(logtab (make-array order :initial-element -1)))

35

(do ((i 1 (1+ i)))

36

((>= i order))

37

(setf (aref exptab i) (* (aref exptab (- i 1)) 2))

38

(when (>= (aref exptab i) order)

39

(setf (aref exptab i)

40

(boole boole-and (- order 1)

41

(boole boole-xor (aref exptab i) ppoly))))

42

(setf (aref logtab (aref exptab i)) i))

43

(setf (aref logtab 1) 0)

44

(setf (slot-value gf 'exp-table) exptab)

45

(setf (slot-value gf 'log-table) logtab)))

46

47

;;; value accessor

48

(defgeneric gf-exp (gf pow)

49

(:documentation "2^POW under Galois Field GF"))

50

(defgeneric gf-log (gf value)

51

(:documentation "VALUE should be within range [0, 2^POW - 1]"))

52

53

(defmethod gf-exp ((gf galois) pow)

54

(let* ((sz (- (gf-order gf) 1))

55

(idx (mod pow sz)))

56

(aref (slot-value gf 'exp-table) idx)))

57

58

(defmethod gf-log ((gf galois) value)

59

(let* ((sz (gf-order gf))

60

(idx (mod value sz)))

61

(aref (slot-value gf 'log-table) idx)))

62

63

;;; Galois Field arithmetic

64

(defgeneric gf-add (gf a b))

65

(defgeneric gf-subtract (gf a b))

66

(defgeneric gf-multiply (gf a b))

67

(defgeneric gf-divide (gf a b))

68

69

(defmethod gf-add ((gf galois) a b)

70

(boole boole-xor a b))

71

72

(defmethod gf-subtract ((gf galois) a b)

73

(boole boole-xor a b))

74

75

(defmethod gf-multiply ((gf galois) a b)

76

(let ((sum (+ (gf-log gf a) (gf-log gf b))))

77

(gf-exp gf sum)))

78

79

(defmethod gf-divide ((gf galois) a b)

80

(when (= b 0)

81

(error "divide by zero"))

82

(if (= a 0)

83

0

84

(let ((sub (- (gf-log gf a) (gf-log gf b))))

85

(gf-exp gf sub))))

86

87

;;; open-paren at beg of line confuses `slime-compile-defun` which uses

88

;;; elisp function `beginning-of-defun`, which in turn involves

89

;;; backward-searching open-paren at beg of line

90

;;; there seems to be no easy way to fix this problem

91

;; with an extra leading '\', docstring is kind of ulgy now, though

92

(defmacro with-gf-accessors (accessors gf &body body)

93

"shortcuts for gf-exp & gf-log, usage:

94

\(with-gf-accessors ((gfexp gf-exp)) *gf-instance* ...)"

95

`(labels ,(mapcar (lambda (acc-entry)

96

(let ((acc-name (car acc-entry))

97

(method-name (cadr acc-entry)))

98

`(,acc-name (a)

99

(,method-name ,gf a))))

100

accessors)

101

,@body))

102

103

(defmacro with-gf-arithmetics (ariths gf &body body)

104

"shortcuts for gf-add, gf-subtract, gf-multiply & gf-divide, usage:

105

\(with-gf-arithmetics ((gf+ gf-add)) *gf-instance* ...)"

106

`(labels ,(mapcar (lambda (arith-entry)

107

(let ((arith-name (car arith-entry))

108

(method-name (cadr arith-entry)))

109

`(,arith-name (a b)

110

(,method-name ,gf a b))))

111

ariths)

112

,@body))

113

114

(defmacro with-gf-shortcuts (accessors ariths gf &body body)

115

"combined with-gf-accessors & with-gf-arithmetics, usage:

116

\(with-gf-shortcuts ((gflog gf-log)) ((gf* gf-multiply)) *gf-instance* ...)"

117

`(labels ,(append

118

(mapcar (lambda (acc-entry)

119

(let ((acc-name (car acc-entry))

120

(method-name (cadr acc-entry)))

121

`(,acc-name (a)

122

(,method-name ,gf a))))

123

accessors)

124

(mapcar (lambda (arith-entry)

125

(let ((arith-name (car arith-entry))

126

(method-name (cadr arith-entry)))

127

`(,arith-name (a b)

128

(,method-name ,gf a b))))

129

ariths))

130

,@body))

131

132

;;;; Bose-Chaudhuri-Hocquenghem (BCH) error correction code

133

134

;;; Polynomial (using list) arithmetics

135

;;; by polynomial list (3 2 1), we mean 3*x^2 + 2*x + 1

136

(defun poly-ash (poly s)

137

"shift left POLY by S"

138

(declare (type list poly))

139

(append poly (make-list s :initial-element 0)))

140

(defun poly-multiply (poly b &optional (op #'*))

141

"multiply B on every element of POLY using OP"

142

(labels ((mult (elem)

143

(funcall op elem b)))

144

(mapcar #'mult poly)))

145

(defun poly-substract (lhs rhs &optional (op #'-))

146

(labels ((sub (elem1 elem2)

147

(funcall op elem1 elem2)))

148

(mapcar #'sub lhs rhs)))

149

(defun poly-mod (msg gen rem &optional (sub #'poly-substract) (mul #'poly-multiply))

150

"MSG % GEN, with REM remainders"

151

(labels ((cdrnzero (msg rem)

152

(do ((head msg (cdr head)))

153

((or (null head) (<= (length head) rem) (/= (car head) 0)) head)

154

head)))

155

(do ((m (poly-ash msg rem) (cdrnzero m rem)))

156

((<= (length m) rem) m)

157

(let* ((glen (length gen))

158

(sft (- (length m) glen))

159

;; LEAD coffiecient of message polynomial

160

(lead (car m)))

161

(setf m (funcall sub m (poly-ash (funcall mul gen lead) sft)))))))

162

163

(defclass bch-ecc ()

164

((k :initform nil :initarg :k

165

:documentation "# of data codewords")

166

(ec :initform nil :initarg :ec

167

:documentation "# of error correction codewords")))

168

169

(defun bch* (poly b)

170

(poly-multiply poly b))

171

(defun bch- (lhs rhs)

172

(labels ((xor (a b)

173

(boole boole-xor a b)))

174

(poly-substract lhs rhs #'xor)))

175

(defun bch-xor (lhs rhs)

176

(labels ((xor (a b)

177

(boole boole-xor a b)))

178

(mapcar #'xor lhs rhs)))

179

(defun bch% (msg gen rem)

180

(poly-mod msg gen rem #'bch- #'bch*))

181

182

(defgeneric bch-ecc (bch msgpoly genpoly)

183

(:documentation "do bch error correction under BCH(K+EC, K)"))

184

185

(defmethod bch-ecc ((bch bch-ecc) msg gen)

186

(with-slots (k ec) bch

187

(unless (= (length msg) k)

188

(error "wrong msg length, expect: ~A; got: ~A~%" k (length msg)))

189

(bch% msg gen ec)))

190

191

;;; As used by format information ecc & version information ecc respectively

192

;;; BCH(15, 5) & BCH(18, 6)

193

(let ((fi-ecc (make-instance 'bch-ecc :k 5 :ec 10))

194

;; format information generator polynomial

195

;; x^10 + x^8 + x^5 + x^4 + x^2 + x + 1

196

(fi-gpoly '(1 0 1 0 0 1 1 0 1 1 1))

197

(fi-xor '(1 0 1 0 1 0 0 0 0 0 1 0 0 1 0)))

198

(defun format-ecc (level mask-ind)

199

(let ((seq (append (level-indicator level)

200

(mask-pattern-ref mask-ind))))

201

(bch-xor (append seq (bch-ecc fi-ecc seq fi-gpoly))

202

fi-xor))))

203

204

(let ((vi-ecc (make-instance 'bch-ecc :k 6 :ec 12))

205

;; version information generator polynomial

206

;; x^12 + x^11 + x^10 + x^9 + x^8 + x^5 + x^2 + 1

207

(vi-gpoly '(1 1 1 1 1 0 0 1 0 0 1 0 1)))

208

(defun version-ecc (version)

209

(let ((seq (decimal->bstream version 6)))

210

(append seq (bch-ecc vi-ecc seq vi-gpoly)))))

211

212

(defclass rs-ecc ()

213

((k :initform nil :initarg :k

214

:documentation "# of data codewords")

215

(ec :initform nil :initarg :ec

216

:documentation "# of error correction codewords")

217

(gpoly :initform nil :reader gpoly

218

:documentation "with EC, we calculate generator poly immediately")))

219

220

;;; Reed-Solomon code uses GF(2^8) with prime polynomial 285,

221

;;; or 1,0001,1101, or (x^8 + x^4 + x^3 + x^2 + 1)

222

(let ((gf256 (make-instance 'galois :power 8 :ppoly 285)))

223

;; Polynomial arithmetics under GF(2^8), as used by Reed-Solomon ecc

224

(defun rs* (poly b)

225

"multiply B on every element of POLY under GF(2^8)"

226

(with-gf-arithmetics ((gf* gf-multiply)) gf256

227

(poly-multiply poly b #'gf*)))

228

(defun rs- (lhs rhs)

229

(with-gf-arithmetics ((gf- gf-subtract)) gf256

230

(poly-substract lhs rhs #'gf-)))

231

(defun rs% (msg gen rem)

232

(poly-mod msg gen rem #'rs- #'rs*))

233

234

(defmethod initialize-instance :after ((rs rs-ecc) &rest args)

235

(declare (ignore args))

236

(setf (slot-value rs 'gpoly) (gen-poly rs)))

237

238

(defgeneric gen-poly (rs))

239

(defmethod gen-poly ((rs rs-ecc))

240

"Generator Polynomial: (x-a^0) * (x-a^1) * ... * (x-a^(ec-1))"

241

(with-slots (ec) rs

242

(let* ((size (+ ec 1))

243

(poly (make-list size :initial-element nil)))

244

(with-gf-shortcuts ((gfexp gf-exp)) ((gf+ gf-add) (gf* gf-multiply)) gf256

245

(setf (nth 0 poly) 1

246

(nth 1 poly) 1)

247

(do ((i 2 (1+ i)))

248

((> i ec) poly)

249

(setf (nth i poly) 1)

250

(do ((j (- i 1) (1- j)))

251

((<= j 0))

252

(if (not (= (nth j poly) 0))

253

(setf (nth j poly)

254

(gf+ (nth (- j 1) poly)

255

(gf* (nth j poly) (gfexp (- i 1)))))

256

(setf (nth j poly) (nth (- j 1) poly))))

257

(setf (nth 0 poly) (gf* (nth 0 poly) (gfexp (- i 1))))))

258

(reverse poly))))

259

260

(defgeneric gen-poly-gflog (rs))

261

(defgeneric ecc-poly (rs msg))

262

263

(defmethod gen-poly-gflog ((rs rs-ecc))

264

(with-gf-accessors ((gflog gf-log)) gf256

265

;; GPOLY already calculated when making new instance

266

(mapcar #'gflog (gpoly rs))))

267

268

(defmethod ecc-poly ((rs rs-ecc) msg-poly)

269

"Error Correction codewords Polynomial for MSG-POLY"

270

(with-slots (k ec gpoly) rs

271

(unless (= (length msg-poly) k)

272

(error "wrong msg-poly length, expect: ~A~%" k))

273

(rs% msg-poly gpoly ec))))

274

275

(deftype qr-mode ()

276

'(member :unknown

277

:numeric :alnum :byte :kanji

278

;; Extended Channel Interpretation, Structured Append, FNC1

279

:eci :structured :fnc1))

280

281

(defun mode-indicator (mode)

282

(declare (type qr-mode mode))

283

(case mode

284

(:numeric '(0 0 0 1)) ; "0001"

285

(:alnum '(0 0 1 0)) ; "0010"

286

(:byte '(0 1 0 0)) ; "0100"

287

(:kanji '(1 0 0 0)) ; "1000"

288

(:eci '(0 1 1 1)) ; "0111"

289

(:structured '(0 0 1 1)) ; "0011"

290

(:fnc1 '(0 1 0 1)))) ; FIXME: "0101" & "1001"

291

292

(defun terminator (bstream version level)

293

"End of message"

294

(let* ((nbits (length bstream))

295

(diff (- (* (data-words-capacity version level) 8)

296

nbits)))

297

(cond

298

((< diff 0) (error "you serious about this?!"))

299

((<= diff 4) (make-list diff :initial-element 0))

300

(t (make-list 4 :initial-element 0)))))

301

302

(defun byte-value (mode byte)

303

"BYTE value under MODE"

304

(declare (type qr-mode mode))

305

(case mode

306

(:numeric

307

(and (<= #x30 byte #x39)

308

(- byte #x30)))

309

(:alnum

310

(cond

311

((<= #x30 byte #x39) (- byte #x30)) ; 0-9

312

((<= #x41 byte #x5A) (+ (- byte #x41) 10)) ; A-Z

313

((= byte #x20) 36) ; SP

314

((= byte #x24) 37) ; $

315

((= byte #x25) 38) ; %

316

((= byte #x2A) 39) ; *

317

((= byte #x2B) 40) ; +

318

((= byte #x2D) 41) ; -

319

((= byte #x2E) 42) ; .

320

((= byte #x2F) 43) ; /

321

((= byte #x3A) 44) ; :

322

(t nil)))

323

((:byte :kanji) byte)))

324

325

(defun kanji-word-p (word)

326

"(kanji-p, kanji-range: {0, 1})"

327

(cond

328

((<= #x8140 word #x9ffc) (values t 0))

329

((<= #xe040 word #xebbf) (values t 1))

330

(t (values nil nil))))

331

332

(defun starts-kanji-p (bytes)

333

"(BYTES starts with kanji-p, kanji word value, kanji-range: {0, 1})"

334

(declare (type list bytes))

335

(let* ((first (car bytes))

336

(second (cadr bytes))

337

(word (and second (+ (ash first 8) second))))

338

(if (and first second)

339

(multiple-value-bind (kanji-p range)

340

(kanji-word-p word)

341

(values kanji-p word range))

342

(values nil nil nil))))

343

344

(defun xor-subset-of (bytes)

345

"exclusive subset of first unit of BYTES.

346

as for unit, one byte for :numeric, :alnum; two bytes for :kanji"

347

(declare (type list bytes))

348

(let* ((first (car bytes)))

349

(cond

350

((null first) :unknown)

351

((byte-value :numeric first) :numeric)

352

((byte-value :alnum first) :alnum)

353

;; excluding reserved values 80-9F & E0-FF

354

((and (not (<= #x80 first #x9F))

355

(not (<= #xE0 first #xFF)))

356

:byte)

357

((starts-kanji-p bytes)

358

:kanji))))

359

360

(defclass qr-input ()

361

((bytes

362

:initform nil :initarg :bytes :reader bytes :type list

363

:documentation "list of bytes to be encoded")

364

(version

365

:initform 1 :initarg :version :reader version

366

:documentation "version of qr symbol, adapted according to BYTES")

367

(ec-level ; cannot be NIL

368

:initform :level-m :initarg :ec-level :reader level :type ecc-level)

369

(mode

370

:initform nil :initarg :mode :reader mode :type (or null qr-mode)

371

:documentation "if supplied, we force all BYTES to be under MODE,

372

therefore, unless you know exactly what you are doing, leave this NIL")

373

(cur-byte

374

:initform 0 :accessor cur-byte

375

:documentation "index of BYTES during data analysis")

376

(segments

377

:initform nil :accessor segments :type list

378

:documentation

379

"list of list, of the form ((:mode1 byte ...) (:mode2 byte ...) ...)")

380

(bstream

381

:initform nil :reader bstream :type list

382

:documentation "list of 0-1 values after encoding SEGMENTS")

383

(blocks

384

:initform nil :reader blocks :type list

385

:documentation "list of list, of the form ((codeword ...) (codeword ...) ...)

386

after converting BSTREAM to codewords")

387

(ecc-blocks ; error correction blocks

388

:initform nil :reader ecc-blocks :type list

389

:documentation "list of list, ec codewords corresponding to BLOCKS")

390

(msg-codewords

391

:initform nil :reader message :type list

392

:documentation "list of codewords from BLOCKS & ECC-BLOCKS,

393

interleaving if neccessary")

394

(matrix

395

:initform nil :accessor matrix

396

:documentation "raw QR code symbol (without masking) as matrix")))

397

398

(defmethod initialize-instance :after ((input qr-input) &rest args)

399

(declare (ignore args))

400

(validate-and-analysis input))

401

402

;;; 0) Data analysis

403

(defgeneric validate-and-analysis (input)

404

(:documentation "adapt VERSION according to BYTES, and fill SEGMENTS slot"))

405

;;; 1) Data encoding

406

(defgeneric data-encoding (input)

407

(:documentation "encode SEGMENTS into BSTREAM slot"))

408

;;; 2) Error correction coding

409

(defgeneric ec-coding (input)

410

(:documentation "split BSTREAM into BLOCKS, do rs-ecc, and fill ECC-BLOCKS"))

411

;;; 3) Structure final message

412

(defgeneric structure-message (input)

413

(:documentation "interleaving BLOCKS and ECC-BLOCKS into MSG-CODEWORDS"))

414

;;; 4) Codeword placement in matrix, a.k.a, raw QR code symbol

415

(defgeneric module-placement (input)

416

(:documentation "write MSG-CODEWORDS into the raw (without masking) MATRIX"))

417

;;; 5) Data masking & Format information

418

(defgeneric data-masking (input)

419

(:documentation "mask MATRIX with best pattern, generate the final symbol"))

420

421

(defgeneric data-analysis (input)

422

(:documentation "BYTES -> SEGMETS, switch bewteen modes as necessary to

423

achieve the most efficient conversion of data"))

424

(defgeneric redo-data-analysis (input)

425

(:documentation "VERSION changed, reset CUR-BYTE and redo data analysis"))

426

(defgeneric analyse-byte-mode (input &optional seg))

427

(defgeneric analyse-alnum-mode (input &optional seg))

428

(defgeneric analyse-numeric-mode (input &optional seg))

429

(defgeneric analyse-kanji-mode (input &optional seg))

430

(defgeneric append-cur-byte (input &optional seg)

431

(:documentation "append CUR-BYTE of BYTES into SEGMENTS"))

432

(defun mode-analyse-func (mode)

433

"put CUR-BYTE into MODE, and then look at following BYTES for new segment"

434

(case mode

435

(:byte #'analyse-byte-mode)

436

(:alnum #'analyse-alnum-mode)

437

(:numeric #'analyse-numeric-mode)

438

(:kanji #'analyse-kanji-mode)))

439

440

(defmethod data-analysis ((input qr-input))

441

(with-slots (mode cur-byte segments) input

442

(when mode ; MODE supplied

443

(let ((seg (append (list mode) (bytes input))))

444

(setf cur-byte (length (bytes input)))

445

(setf segments (append segments (list seg))))

446

(return-from data-analysis)))

447

(with-slots (bytes version segments) input

448

(let ((init-mode (select-init-mode bytes version)))

449

(funcall (mode-analyse-func init-mode) input))))

450

451

(defmethod redo-data-analysis ((input qr-input))

452

(with-slots (cur-byte segments) input

453

(setf cur-byte 0)

454

(setf segments nil)

455

(data-analysis input)))

456

457

(defun select-init-mode (bytes version)

458

"optimization of bitstream length: select initial mode"

459

(declare (type list bytes))

460

(let ((init-xor (xor-subset-of bytes)))

461

(case init-xor

462

(:byte :byte)

463

(:kanji

464

(case (xor-subset-of (nthcdr 2 bytes))

465

((:numeric :alnum) :kanji)

466

(:byte

467

(let ((nunits (ecase (version-range version)

468

((0 1) 5)

469

(2 6))))

470

(if (every-unit-matches (nthcdr 3 bytes) 2 nunits :kanji)

471

:byte

472

:kanji)))

473

(otherwise :kanji)))

474

(:alnum

475

(let ((nunits (ecase (version-range version)

476

(0 6) (1 7) (2 8))))

477

;; number of units (characters) match :alnum, followed by a :byte unit

478

(multiple-value-bind (n last-mode) (nunits-matches (cdr bytes) :alnum)

479

(if (and (< n nunits) (eq last-mode :byte))

480

:byte

481

:alnum))))

482

(:numeric

483

(let ((nbunits (ecase (version-range version)

484

((0 1) 4) (2 5)))

485

(naunits (ecase (version-range version)

486

(0 7) (1 8) (2 9))))

487

(multiple-value-bind (n last-mode) (nunits-matches (cdr bytes) :numeric)

488

(if (and (< n nbunits) (eq last-mode :byte))

489

:byte

490

(if (and (< n naunits) (eq last-mode :alnum))

491

:alnum

492

:numeric))))))))

493

494

;;; UNIT: character under a certain mode,

495

;;; a byte under :numeric :alnum & :byte, or a byte-pair under :kanji

496

(defun every-unit-matches (bytes usize nunits mode)

497

"if every unit of USZIE bytes (at most NUNITS unit) within BYTES matches MODE"

498

(declare (type list bytes) (type qr-mode mode))

499

(when (>= (length bytes) (* usize nunits))

500

(dotimes (i nunits)

501

(let ((b (nthcdr (* usize i) bytes)))

502

(unless (eq (xor-subset-of b) mode)

503

(return-from every-unit-matches nil))))

504

(return-from every-unit-matches t)))

505

506

(defun nunits-matches (bytes mode)

507

"(number of units that matches MODE, and mode for the first unmatched unit)"

508

(declare (type list bytes) (type qr-mode mode))

509

(let ((usize (ecase mode

510

((:byte :alnum :numeric) 1)

511

;; as for :kanji, 2 bytes forms a single unit

512

(:kanji 2)))

513

(nunits 0))

514

(do ((b bytes (nthcdr usize b)))

515

((or (null b)

516

(not (eq (xor-subset-of b) mode)))

517

(values nunits (xor-subset-of b)))

518

(incf nunits))))

519

520

(defmethod analyse-byte-mode ((input qr-input) &optional (seg '(:byte)))

521

(declare (type list seg))

522

(setf seg (append-cur-byte input seg))

523

(unless seg

524

(return-from analyse-byte-mode))

525

(with-slots (bytes cur-byte version segments) input

526

(let* ((range (version-range version))

527

(nkunits (ecase range ; number of :kanji units before more :byte

528

(0 9) (1 12) (2 13)))

529

(nanuits (ecase range ; number of :alnum units before more :byte

530

(0 11) (1 15) (2 16)))

531

(nmunits1 (ecase range ; number of :numeric units before more :byte

532

(0 6) (1 8) (2 9)))

533

(nmunits2 (ecase range ; number of :numeric units before more :alnum

534

(0 6) (1 7) (2 8)))

535

(switch-mode nil))

536

(multiple-value-bind (nmatches last-mode)

537

(nunits-matches (nthcdr cur-byte bytes) :kanji)

538

(and (>= nmatches nkunits) (eq last-mode :byte)

539

(setf switch-mode :kanji)))

540

(unless switch-mode

541

(multiple-value-bind (nmatches last-mode)

542

(nunits-matches (nthcdr cur-byte bytes) :alnum)

543

(and (>= nmatches nanuits) (eq last-mode :byte)

544

(setf switch-mode :alnum))))

545

(unless switch-mode

546

(multiple-value-bind (nmatches last-mode)

547

(nunits-matches (nthcdr cur-byte bytes) :numeric)

548

(case last-mode

549

(:byte (and (>= nmatches nmunits1)

550

(setf switch-mode :numeric)))

551

(:alnum (and (>= nmatches nmunits2)

552

(setf switch-mode :numeric))))))

553

(if switch-mode

554

(progn

555

;; current segment finished, add a new SWITCH-MODE segment

556

(setf segments (append segments (list seg)))

557

(setf seg (list switch-mode)))

558

(setf switch-mode :byte))

559

(funcall (mode-analyse-func switch-mode) input seg))))

560

561

(defmethod analyse-alnum-mode ((input qr-input) &optional (seg '(:alnum)))

562

(declare (type list seg))

563

(setf seg (append-cur-byte input seg))

564

(unless seg

565

(return-from analyse-alnum-mode))

566

(with-slots (bytes cur-byte version segments) input

567

(let ((nmunits (ecase (version-range version)

568

(0 13) (1 15) (2 17)))

569

(switch-mode nil))

570

(when (>= (nunits-matches (nthcdr cur-byte bytes) :kanji) 1)

571

(setf switch-mode :kanji))

572

(unless switch-mode

573

(when (>= (nunits-matches (nthcdr cur-byte bytes) :byte) 1)

574

(setf switch-mode :byte)))

575

(unless switch-mode

576

(multiple-value-bind (nmatches last-mode)

577

(nunits-matches (nthcdr cur-byte bytes) :numeric)

578

(and (>= nmatches nmunits) (eq last-mode :alnum)

579

(setf switch-mode :numeric))))

580

(if switch-mode

581

(progn

582

(setf segments (append segments (list seg)))

583

(setf seg (list switch-mode)))

584

(setf switch-mode :alnum))

585

(funcall (mode-analyse-func switch-mode) input seg))))

586

587

(defmethod analyse-numeric-mode ((input qr-input) &optional (seg '(:numeric)))

588

(declare (type list seg))

589

(setf seg (append-cur-byte input seg))

590

(unless seg

591

(return-from analyse-numeric-mode))

592

(with-slots (bytes cur-byte version segments) input

593

(let ((switch-mode nil))

594

(when (>= (nunits-matches (nthcdr cur-byte bytes) :kanji) 1)

595

(setf switch-mode :kanji))

596

(unless switch-mode

597

(when (>= (nunits-matches (nthcdr cur-byte bytes) :byte) 1)

598

(setf switch-mode :byte)))

599

(unless switch-mode

600

(when (>= (nunits-matches (nthcdr cur-byte bytes) :alnum) 1)

601

(setf switch-mode :alnum)))

602

(if switch-mode

603

(progn

604

(setf segments (append segments (list seg)))

605

(setf seg (list switch-mode)))

606

(setf switch-mode :numeric))

607

(funcall (mode-analyse-func switch-mode) input seg))))

608

609

(defmethod append-cur-byte ((input qr-input) &optional seg)

610

"if CUR-BYTE is the last byte, return nil"

611

(declare (type list seg))

612

(with-slots (bytes cur-byte segments) input

613

(setf seg (append seg (list (nth cur-byte bytes))))

614

(incf cur-byte)

615

(when (>= cur-byte (length bytes))

616

(setf segments (append segments (list seg)))

617

(setf seg nil))

618

(return-from append-cur-byte seg)))

619

620

(defmethod analyse-kanji-mode ((input qr-input) &optional (seg '(:kanji)))

621

(declare (type list seg))

622

(with-slots (bytes cur-byte segments) input

623

(setf seg (append seg (nthcdr cur-byte bytes)))

624

(setf cur-byte (length bytes))

625

(setf segments (append segments (list seg)))))

626

627

(defmethod validate-and-analysis ((input qr-input))

628

(with-slots ((level ec-level) segments) input

629

(unless (<= 1 (version input) 40)

630

(error "version ~A out of bounds" (version input)))

631

(do ((prev -1))

632

((<= (version input) prev))

633

(setf prev (version input))

634

(redo-data-analysis input)

635

(labels ((seg-bstream-len (seg)

636

(segment-bstream-length seg (version input))))

637

(let* ((blen (reduce #'+ (mapcar #'seg-bstream-len segments)

638

:initial-value 0))

639

(min-v (minimum-version prev (ceiling blen 8) level)))

640

(if min-v

641

(setf (slot-value input 'version) min-v)

642

(error "no version to hold ~A bytes" (ceiling blen 8))))))))

643

644

(defmethod data-encoding ((input qr-input))

645

(with-slots (version (level ec-level) segments) input

646

(labels ((seg->bstream (seg)

647

(segment->bstream seg version)))

648

(let* ((bs (reduce #'append (mapcar #'seg->bstream segments)

649

:initial-value nil))

650

(tt (terminator bs version level))

651

;; connect bit streams in all segment, with terminator appended

652

(bstream (append bs tt)))

653

;; add padding bits

654

(setf bstream (append bstream (padding-bits bstream)))

655

;; add pad codewords, finishes data encoding

656

(setf (slot-value input 'bstream)

657

(append bstream

658

(pad-codewords bstream version level)))))))

659

660

(defmethod ec-coding ((input qr-input))

661

(with-slots (version (level ec-level) bstream) input

662

(let ((codewords (bstream->codewords bstream))

663

(blocks nil)

664

(ecc-blocks nil)

665

;; RS error correction obj for blk1 & blk2

666

(rs1 nil)

667

(rs2 nil))

668

(multiple-value-bind (ecc-num blk1 data1 blk2 data2)

669

(ecc-block-nums version level)

670

(when (> blk1 0)

671

(setf rs1 (make-instance 'rs-ecc :k data1 :ec ecc-num)))

672

(when (> blk2 0)

673

(setf rs2 (make-instance 'rs-ecc :k data2 :ec ecc-num)))

674

(dotimes (i blk1)

675

(setf blocks

676

(append blocks (list (subseq codewords 0 data1))))

677

(setf codewords (nthcdr data1 codewords)))

678

(dotimes (i blk2)

679

(setf blocks

680

(append blocks (list (subseq codewords 0 data2))))

681

(setf codewords (nthcdr data2 codewords)))

682

(dotimes (i blk1)

683

(setf ecc-blocks

684

(append ecc-blocks (list (ecc-poly rs1 (nth i blocks))))))

685

(dotimes (i blk2)

686

(setf ecc-blocks

687

(append ecc-blocks (list (ecc-poly rs2 (nth (+ i blk1) blocks))))))

688

(setf (slot-value input 'blocks) blocks)

689

(setf (slot-value input 'ecc-blocks) ecc-blocks)))))

690

691

(defmethod structure-message ((input qr-input))

692

(with-slots (version (level ec-level) blocks ecc-blocks) input

693

(let ((final nil))

694

(multiple-value-bind (ecc-num blk1 data1 blk2 data2)

695

(ecc-block-nums version level)

696

(declare (ignore ecc-num))

697

(setf (slot-value input 'msg-codewords)

698

(append final

699

;; interleave data blocks, data blocks may differ in length

700

(take-data-in-turn blocks blk1 data1 blk2 data2)

701

;; we know error correction blocks are of the same length

702

(take-in-turn ecc-blocks)))))))

703

704

(defmethod module-placement ((input qr-input))

705

(setf (matrix input) (make-matrix (version input)))

706

(with-slots (version msg-codewords matrix) input

707

;; Function pattern placement

708

(function-patterns matrix version)

709

;; Symbol character placement

710

(let ((rbits (remainder-bits version))

711

(bstream nil))

712

(labels ((dec->byte (codeword)

713

(decimal->bstream codeword 8)))

714

(setf bstream (append (reduce #'append (mapcar #'dec->byte msg-codewords))

715

;; data capacity of _symbol_ does not divide by 8

716

(make-list rbits :initial-element 0))))

717

(symbol-character bstream matrix version))))

718

719

(defmethod data-masking ((input qr-input))

720

"(masked matrix, mask pattern reference)"

721

(with-slots (version (level ec-level) matrix) input

722

(let ((modules (matrix-modules version)))

723

(multiple-value-bind (masked indicator)

724

(choose-masking matrix modules level)

725

(values masked (mask-pattern-ref indicator))))))

726

727

(defun decimal->bstream (dec nbits)

728

"using NBITS bits to encode decimal DEC"

729

(let ((bstream nil))

730

(dotimes (i nbits)

731

(if (logbitp i dec)

732

(push 1 bstream)

733

(push 0 bstream)))

734

bstream))

735

(defun bstream->decimal (bstream nbits)

736

(declare (type list bstream))

737

(let ((nbits (min nbits (length bstream)))

738

(dec 0))

739

(dotimes (i nbits)

740

(setf dec (+ (* dec 2) (nth i bstream))))

741

dec))

742

743

;;; :numeric mode

744

(defun group->decimal (values ndigits)

745

"digit groups of length NDIGITS (1, 2 or 3) to decimal"

746

(declare (type list values))

747

(case ndigits

748

(1 (nth 0 values))

749

(2 (+ (* (nth 0 values) 10) (nth 1 values)))

750

(3 (+ (* (nth 0 values) 100) (* (nth 1 values) 10) (nth 2 values)))))

751

(defun final-digit-bits (n)

752

"the final one or two digits are converted to 4 or 7 bits respectively"

753

(case n

754

(0 0) (1 4) (2 7)))

755

(defun numeric->bstream (bytes)

756

(declare (type list bytes))

757

(labels ((num-value (byte)

758

(byte-value :numeric byte)))

759

(let ((values (mapcar #'num-value bytes))

760

(bstream nil))

761

(do ((v values (nthcdr 3 v)))

762

((null v) bstream)

763

(case (length v)

764

(1 ; only 1 digits left

765

(setf bstream

766

(append bstream (decimal->bstream (group->decimal v 1)

767

                                                    (final-digit-bits 1)))))

768

(2 ; only 2 digits left

769

(setf bstream

770

(append bstream (decimal->bstream (group->decimal v 2)

771

                                                    (final-digit-bits 2)))))

772

(otherwise ; at least 3 digits left

773

(setf bstream

774

(append bstream

775

(decimal->bstream (group->decimal v 3) 10)))))))))

776

777

;;; :alnum mode

778

(defun pair->decimal (values num)

779

"alnum pairs of length NUM (1 or 2) to decimal"

780

(declare (type list values))

781

(case num

782

(1 (nth 0 values))

783

(2 (+ (* (nth 0 values) 45) (nth 1 values)))))

784

(defun alnum->bstream (bytes)

785

(declare (type list bytes))

786

(labels ((alnum-value (byte)

787

(byte-value :alnum byte)))

788

(let ((values (mapcar #'alnum-value bytes))

789

(bstream nil))

790

(do ((v values (nthcdr 2 v)))

791

((null v) bstream)

792

(case (length v)

793

(1 ; only 1 alnum left

794

(setf bstream

795

(append bstream

796

(decimal->bstream (pair->decimal v 1) 6))))

797

(otherwise ; at least 2 alnum left

798

(setf bstream

799

(append bstream

800

(decimal->bstream (pair->decimal v 2) 11)))))))))

801

802

;;; :byte mode

803

(defun byte->bstream (bytes)

804

(declare (type list bytes))

805

(labels ((join (prev cur)

806

(append prev (decimal->bstream (byte-value :byte cur) 8))))

807

(reduce #'join bytes :initial-value nil)))

808

809

;;; :kanji mode

810

(defun kanji->decimal (word range)

811

(let ((subtractor (ecase range

812

(0 #x8140)

813

(1 #xc140))))

814

(decf word subtractor)

815

(setf word (+ (* (ash word -8) #xc0)

816

(boole boole-and word #xff)))))

817

(defun kanji->bstream (bytes)

818

(declare (type list bytes))

819

(labels ((kanji-value (byte)

820

(byte-value :kanji byte)))

821

(let ((values (mapcar #'kanji-value bytes))

822

(delta 1)

823

(bstream nil))

824

(do ((v values (nthcdr delta v)))

825

((null v) bstream)

826

(case (length v)

827

(1 ; only 1 byte left

828

(setf bstream

829

(append bstream (decimal->bstream (car v) 13)))

830

(setf delta 1))

831

(otherwise ; at least 2 bytes left

832

(multiple-value-bind (kanji-p word range) (starts-kanji-p v)

833

(if kanji-p

834

(progn

835

(setf bstream

836

(append bstream

837

(decimal->bstream (kanji->decimal word range)

838

13)))

839

(setf delta 2))

840

(progn

841

(setf bstream

842

(append bstream (decimal->bstream (car v) 13)))

843

(setf delta 1))))))))))

844

845

;;; :eci mode

846

(defun eci->bstream (bytes)

847

"TODO"

848

(declare (ignore bytes))

849

(error "eci->bstream: TODO..."))

850

851

(defun bstream-trans-func (mode)

852

(case mode

853

(:numeric #'numeric->bstream)

854

(:alnum #'alnum->bstream)

855

(:byte #'byte->bstream)

856

(:kanji #'kanji->bstream)))

857

858

(defun kanji-bytes-length (bytes)

859

(declare (type list bytes))

860

(let ((step 1)

861

(len 0))

862

(do ((b bytes (nthcdr step b)))

863

((null b) len)

864

(if (starts-kanji-p b)

865

(setf step 2)

866

(setf step 1))

867

(incf len))))

868

869

(defun bytes-length (bytes mode)

870

"number of data characters under MODE"

871

(declare (type list bytes) (type qr-mode mode))

872

(case mode

873

((:numeric :alnum :byte) (length bytes))

874

(:kanji (kanji-bytes-length bytes))))

875

876

(defun segment-bstream-length (segment version)

877

"bit stream length of SEGMENT (:mode b0 b1 ...) under VERSION"

878

(declare (type list segment))

879

(let* ((mode (car segment))

880

(bytes (cdr segment))

881

(m 4)

882

(c (char-count-bits version mode))

883

(d (bytes-length bytes mode))

884

(r 0))

885

;; M = number of bits in mode indicator

886

;; C = number of bits in character count indicator

887

;; D = number of input data characters

888

(case mode

889

(:numeric

890

(setf r (final-digit-bits (mod d 3)))

891

;; B = M + C + 10 * (D / 3) + R

892

(+ m c (* 10 (floor d 3)) r))

893

(:alnum

894

(setf r (mod d 2))

895

;; B = M + C + 11 * (D / 2) + 6 * (D % 2)

896

(+ m c (* 11 (floor d 2)) (* 6 r)))

897

(:byte

898

;; B = M + C + 8 * D

899

(+ m c (* 8 d)))

900

(:kanji

901

;; B = M + C + 13 * D

902

(+ m c (* 13 d))))))

903

904

(defun segment->bstream (segment version)

905

"SEGMENT (:mode b0 b1 ...) to bit stream under VERSION"

906

(declare (type list segment))

907

(let* ((mode (car segment))

908

(bytes (cdr segment))

909

(len (bytes-length bytes mode))

910

(n (char-count-bits version mode))

911

(bstream nil))

912

(append bstream (mode-indicator mode)

913

(decimal->bstream len n) ; character count indicator

914

(funcall (bstream-trans-func mode) bytes))))

915

916

(defun padding-bits (bstream)

917

"add padding bits so that BSTREAM ends at a codeword boundary"

918

(multiple-value-bind (quot rem) (ceiling (length bstream) 8)

919

(declare (ignore quot))

920

(make-list (- rem) :initial-element 0)))

921

922

(defun pad-codewords (bstream version level)

923

"add pad codewords (after adding padding-bits) to fill data codeword capacity"

924

(let ((pad-words '((1 1 1 0 1 1 0 0)

925

(0 0 0 1 0 0 0 1)))

926

(pad-len (- (data-words-capacity version level)

927

(/ (length bstream) 8)))

928

(ret nil))

929

(dotimes (i pad-len)

930

(setf ret (append ret (nth (mod i 2) pad-words))))

931

ret))

932

933

(defun bstream->codewords (bstream)

934

"convert bstream into codewords, as coefficients of the terms of a polynomial"

935

(do ((b bstream (nthcdr 8 b))

936

(codewords nil))

937

((null b) codewords)

938

(setf codewords (append codewords (list (bstream->decimal b 8))))))

939

940

(defun take-in-turn (blks)

941

"taking codewords from each block (bound by minimum length) in turn"

942

(reduce #'append (apply #'mapcar #'list blks)))

943

944

(defun take-data-in-turn (blocks blk1 data1 blk2 data2)

945

"taking data words from each block (might have different length) in turn"

946

(let ((data-final nil)

947

(left-blks nil))

948

(setf data-final (take-in-turn blocks))

949

(cond

950

((or (= blk1 0) (= blk2 0))

951

;; only one kind of block exists

952

(setf left-blks nil))

953

((> data1 data2)

954

;; block 1 has more elements left

955

(setf left-blks (mapcar #'(lambda (blk)

956

(nthcdr data2 blk))

957

(subseq blocks 0 blk1))))

958

((> data2 data1)

959

;; block 2 has more elements left

960

(setf left-blks (mapcar #'(lambda (blk)

961

(nthcdr data1 blk))

962

(subseq blocks blk1 (+ blk1 blk2))))))

963

(if left-blks

964

(append data-final (take-in-turn left-blks))

965

data-final)))

966

967

(deftype module-color ()

968

":RAW, nothing has been done to this module; :RESERVE, format info reserve module

969

:FLIGHT/:FDARK, function pattern light/dark module; :LIGHT/:DARK, data modules"

970

'(member :raw :flight :fdark :reserve :light :dark))

971

972

(defun same-color-p (color1 color2)

973

"during QR symbol evaluation, :fdark & :dark are considered to be same"

974

(case color1

975

((:flight :light) (or (eq color2 :flight) (eq color2 :light)))

976

((:fdark :dark) (or (eq color2 :fdark) (eq color2 :fdark)))

977

(otherwise (eq color1 color2))))

978

979

(defun raw-module-p (matrix i j)

980

"nothing has been done to MATRIX[I, J]"

981

(eq (aref matrix i j) :raw))

982

983

(defun make-modules-matrix (modules &optional (init :raw))

984

"make a raw matrix with MODULES * MODULES elements"

985

(make-array `(,modules ,modules) :initial-element init))

986

987

(defun make-matrix (version &optional (init :raw))

988

"make a raw matrix according to VERSION"

989

(let ((n (matrix-modules version)))

990

(make-modules-matrix n init)))

991

992

(defun paint-square (matrix x y n &optional (color :fdark))

993

"Paint a square of size N*N starting from upleft (X, Y) in MATRIX to COLOR"

994

(let ((maxx (+ x n -1))

995

(maxy (+ y n -1)))

996

(loop for i from x to maxx do

997

(loop for j from y to maxy do

998

(setf (aref matrix i j) color))))

999

matrix)

1000

1001

;;; Function Patterns

1002

(defun function-patterns (matrix version)

1003

(let ((modules (matrix-modules version)))

1004

(finder-patterns matrix modules)

1005

(separator matrix modules)

1006

(timing-patterns matrix modules)

1007

(alignment-patterns matrix version))

1008

matrix)

1009

;; a) Finder Patterns: fixed position in matrix

1010

(defun one-finder-pattern (matrix x y)

1011

"Paint one finder pattern starting from upleft (X, Y)"

1012

(paint-square matrix x y 7 :fdark)

1013

(paint-square matrix (+ x 1) (+ y 1) 5 :flight)

1014

(paint-square matrix (+ x 2) (+ y 2) 3 :fdark))

1015

(defun finder-patterns (matrix modules)

1016

;; top-left finder pattern

1017

(one-finder-pattern matrix 0 0)

1018

;; top-right finder pattern

1019

(one-finder-pattern matrix (- modules 7) 0)

1020

;; bottom-left finder pattern

1021

(one-finder-pattern matrix 0 (- modules 7)))

1022

1023

;; b) Separator: fixed position in matrix

1024

(defun separator (matrix modules)

1025

(dotimes (j 8)

1026

;; top-left horizontal separator

1027

(setf (aref matrix 7 j) :flight)

1028

;; top-right horizontal separator

1029

(setf (aref matrix 7 (- modules j 1)) :flight)

1030

;; bottom-left horizontal separator

1031

(setf (aref matrix (- modules 8) j) :flight))

1032

(dotimes (i 8)

1033

;; top-left vertical separator

1034

(setf (aref matrix i 7) :flight)

1035

;; bottom-left vertical separator

1036

(setf (aref matrix (- modules i 1) 7) :flight)

1037

;; top-right vertical separator

1038

(setf (aref matrix i (- modules 8)) :flight))

1039

matrix)

1040

1041

;; c) Timing patterns

1042

(defun timing-patterns (matrix modules)

1043

(let ((color :fdark))

1044

(loop for idx from 8 to (- modules 9) do

1045

(if (evenp idx)

1046

(setf color :fdark)

1047

(setf color :flight))

1048

;; Horizontal

1049

(setf (aref matrix 6 idx) color)

1050

;; Vertical

1051

(setf (aref matrix idx 6) color)))

1052

matrix)

1053

1054

;; d) Alignment Patterns: varies between versions

1055

;; may overlap timing patterns, modules coincide with that of timing patterns

1056

(defun one-align-pattern (matrix x y)

1057

"Paint one alignment pattern centered at (X, Y)"

1058

(paint-square matrix (- x 2) (- y 2) 5 :fdark)

1059

(paint-square matrix (- x 1) (- y 1) 3 :flight)

1060

(paint-square matrix x y 1 :fdark))

1061

(defun alignment-patterns (matrix version)

1062

(dolist (center (align-centers version) matrix)

1063

(one-align-pattern matrix (first center) (second center))))

1064

1065

;;; Encoding Region

1066

(defun symbol-character (bstream matrix version)

1067

(let ((modules (matrix-modules version)))

1068

(reserve-information matrix version)

1069

(bstream-placement bstream matrix modules))

1070

matrix)

1071

;; reserve format information & version information

1072

(defun reserve-information (matrix version)

1073

(let ((modules (matrix-modules version)))

1074

;; format information...

1075

;; top-left & top-right horizontal

1076

(dotimes (j 8)

1077

(when (raw-module-p matrix 8 j)

1078

(setf (aref matrix 8 j) :reserve))

1079

(setf (aref matrix 8 (- modules j 1)) :reserve))

1080

(setf (aref matrix 8 8) :reserve)

1081

;; top-left & bottom-left vertical

1082

(dotimes (i 8)

1083

(when (raw-module-p matrix i 8)

1084

(setf (aref matrix i 8) :reserve))

1085

(setf (aref matrix (- modules i 1) 8) :reserve))

1086

;; dark module...

1087

(setf (aref matrix (- modules 8) 8) :fdark)

1088

1089

;; version information for version 7-40

1090

(when (>= version 7)

1091

(version-information matrix modules version))))

1092

1093

(defun paint-fcolor-bit (matrix i j bit)

1094

"Paint function pattern color for MATRIX[I, J] according to BIT of {0, 1}"

1095

(setf (aref matrix i j) (case bit

1096

(0 :flight) (1 :fdark))))

1097

(defun version-information (matrix modules version)

1098

"version information placement on two blocks of modules:

1099

bottom-left 3*6 block: [modules-11, modules-9] * [0, 5]

1100

top-right 6*3 block: [0, 5] * [modules-11, modules-9]"

1101

(assert (>= version 7))

1102

(let ((vib (version-ecc version))

1103

(i (- modules 9))

1104

(start (- modules 9))

1105

(bound (- modules 11))

1106

(j 5))

1107

(dolist (bit vib matrix)

1108

(paint-fcolor-bit matrix i j bit)

1109

(paint-fcolor-bit matrix j i bit)

1110

(if (>= (- i 1) bound)

1111

(decf i)

1112

(progn

1113

(decf j)

1114

(setf i start))))))

1115

1116

;; Symbol character placement

1117

(defun paint-color-bit (matrix i j bit)

1118

"Paint data color for MATRIX[I, J] according to BIT of {0, 1}"

1119

(setf (aref matrix i j) (case bit

1120

(0 :light) (1 :dark))))

1121

(defun bstream-placement (bstream matrix modules)

1122

"2X4 module block for a regular symbol character. Regard the interleaved

1123

codeword sequence as a single bit stream, which is placed in the two module

1124

wide columns, alternately in the right and left modules, moving upwards or

1125

downwards according to DIRECTION, skipping function patterns, changing DIRECTION

1126

at the top or bottom of the symbol. The only exception is that no block should

1127

ever overlap the vertical timing pattern."

1128

(let ((i (- modules 1))

1129

(j (- modules 1))

1130

;; -1: upwards, +1: downwards

1131

(direction -1)

1132

(len (length bstream)))

1133

(do ((idx 0))

1134

((>= idx len) matrix)

1135

(when (raw-module-p matrix i j)

1136

(paint-color-bit matrix i j (nth idx bstream))

1137

(incf idx))

1138

(when (and (>= (- j 1) 0)

1139

(raw-module-p matrix i (- j 1)))

1140

;; try left module

1141

(paint-color-bit matrix i (- j 1) (nth idx bstream))

1142

(incf idx))

1143

(if (< -1 (+ i direction) modules)

1144

(incf i direction)

1145

(progn

1146

;; reverse direction

1147

(setf direction (- direction))

1148

(if (= j 8)

1149

;; vertical timing pattern reached, the next block starts

1150

;; to the left of it

1151

(decf j 3)

1152

(decf j 2)))))))

1153

1154

;;; format information, during and after masking

1155

(defun format-information (matrix modules level mask-ind)

1156

;; format information bistream

1157

(let ((fib (format-ecc level mask-ind))

1158

(darks 0)

1159

(idx 0)

1160

(idx2 0))

1161

(setf darks (count-if #'(lambda (elem) (= elem 1)) fib))

1162

;; horizontal 14 ~ 8

1163

(loop for j from 0 to 7 do

1164

(when (eq (aref matrix 8 j) :reserve)

1165

(paint-fcolor-bit matrix 8 j (nth idx fib))

1166

(incf idx)))

1167

;; vertical 14 ~ 8

1168

(loop for i from (- modules 1) downto (- modules 7) do

1169

(paint-fcolor-bit matrix i 8 (nth idx2 fib))

1170

(incf idx2))

1171

;; horizontal 7 - 0

1172

(loop for j from (- modules 8) to (- modules 1) do

1173

(paint-fcolor-bit matrix 8 j (nth idx fib))

1174

(incf idx))

1175

;; vertical 7 - 0

1176

(loop for i from 8 downto 0 do

1177

(when (eq (aref matrix i 8) :reserve)

1178

(paint-fcolor-bit matrix i 8 (nth idx2 fib))

1179

(incf idx2)))

1180

(values matrix darks)))

1181

1182

;;; only encoding region modules (excluding format information) are masked

1183

(defun encoding-module-p (matrix i j)

1184

"modules belong to encoding region, excluding format & version information"

1185

(or (eq (aref matrix i j) :light)

1186

(eq (aref matrix i j) :dark)))

1187

(defun non-mask-module-p (matrix i j)

1188

(not (encoding-module-p matrix i j)))

1189

(defun reverse-module-color (matrix i j)

1190

(case (aref matrix i j)

1191

(:dark :light) (:light :dark)))

1192

1193

;;; all modules are evaluated:

1194

;;; there should be only :dark :light :fdark :flight modules left by now

1195

(defun dark-module-p (matrix i j)

1196

(or (eq (aref matrix i j) :fdark)

1197

(eq (aref matrix i j) :dark)))

1198

1199

(defun copy-and-mask (matrix modules level mask-ind)

1200

"make a new matrix and mask using MASK-IND for later evaluation"

1201

(let ((ret (make-modules-matrix modules))

1202

(mask-p (mask-condition mask-ind))

1203

(darks 0))

1204

(dotimes (i modules)

1205

(dotimes (j modules)

1206

(cond

1207

((non-mask-module-p matrix i j)

1208

(setf (aref ret i j) (aref matrix i j)))

1209

((funcall mask-p i j) ; need mask

1210

(setf (aref ret i j) (reverse-module-color matrix i j)))

1211

(t

1212

(setf (aref ret i j) (aref matrix i j))))

1213

(when (dark-module-p ret i j)

1214

(incf darks))))

1215

(multiple-value-bind (dummy fi-darks)

1216

(format-information ret modules level mask-ind)

1217

(declare (ignore dummy))

1218

;; add format information dark modules

1219

(values ret (+ darks fi-darks)))))

1220

1221

(defun mask-matrix (matrix modules level mask-ind)

1222

"do not evaluate, just go ahead and mask MATRIX using MASK-IND mask pattern"

1223

(let ((mask-p (mask-condition mask-ind)))

1224

(dotimes (i modules)

1225

(dotimes (j modules)

1226

(and (encoding-module-p matrix i j)

1227

(funcall mask-p i j)

1228

(setf (aref matrix i j) (reverse-module-color matrix i j)))))

1229

;; paint format information

1230

(format-information matrix modules level mask-ind)

1231

matrix))

1232

1233

(defvar *mask-pattern-num* 8)

1234

1235

(defun choose-masking (matrix modules level)

1236

"mask and evaluate using each mask pattern, choose the best mask result"

1237

(let ((n4 10)

1238

(best-matrix nil)

1239

(mask-indicator nil)

1240

(min-penalty nil)

1241

(square (* modules modules))

1242

(cur-penalty 0))

1243

(dotimes (i *mask-pattern-num*)

1244

(multiple-value-bind (cur-matrix darks)

1245

(copy-and-mask matrix modules level i)

1246

;; feature 4: proportion of dark modules in entire symbol

1247

(let ((bratio (/ (+ (* darks 200) square) square 2)))

1248

(setf cur-penalty (* (/ (abs (- bratio 50)) 5) n4)))

1249

(incf cur-penalty (evaluate-feature-123 cur-matrix modules))

1250

(when (or (null min-penalty)

1251

(< cur-penalty min-penalty))

1252

(setf min-penalty cur-penalty

1253

mask-indicator i

1254

best-matrix cur-matrix))))

1255

(values best-matrix mask-indicator)))

1256

1257

;;; feature 1 & 2 & 3

1258

(defun evaluate-feature-123 (matrix modules)

1259

(let ((penalty 0))

1260

(incf penalty (evaluate-feature-2 matrix modules))

1261

(dotimes (col modules)

1262

(let ((rlength (calc-run-length matrix modules col)))

1263

(incf penalty (evaluate-feature-1 rlength))

1264

(incf penalty (evaluate-feature-3 rlength))))

1265

(dotimes (row modules)

1266

(let ((rlength (calc-run-length matrix modules row :col)))

1267

(incf penalty (evaluate-feature-1 rlength))

1268

(incf penalty (evaluate-feature-3 rlength))))

1269

penalty))

1270

1271

(defun calc-run-length (matrix modules num &optional (direction :row))

1272

"list of number of adjacent modules in same color"

1273

(let ((rlength nil)

1274

(ridx 0))

1275

(labels ((get-elem (idx)

1276

(case direction

1277

(:row (aref matrix num idx))

1278

(:col (aref matrix idx num))))

1279

(add-to-list (list elem)

1280

(append list (list elem))))

1281

;; we make sure (NTH 1 rlength) is for dark module

1282

(when (same-color-p (get-elem 0) :dark)

1283

(setf rlength (add-to-list rlength -1)

1284

ridx 1))

1285

(setf rlength (add-to-list rlength 1))

1286

1287

(loop for i from 1 to (- modules 1) do

1288

(if (same-color-p (get-elem i) (get-elem (- i 1)))

1289

(incf (nth ridx rlength))

1290

(progn

1291

(incf ridx)

1292

(setf rlength (add-to-list rlength 1)))))

1293

rlength)))

1294

1295

(defun evaluate-feature-1 (rlength)

1296

"(5 + i) adjacent modules in row/column in same color. (N1 + i) points, N1 = 3"

1297

(let ((n1 3)

1298

(penalty 0))

1299

(dolist (sz rlength penalty)

1300

(when (> sz 5)

1301

(incf penalty (+ n1 sz -5))))))

1302

1303

(defun evaluate-feature-3 (rlength)

1304

"1:1:3:1:1 ration (dark:light:dark:light:dark) pattern in row/column,

1305

preceded or followed by light area 4 modules wide. N3 points, N3 = 40"

1306

(let ((n3 40)

1307

(len (length rlength))

1308

(penalty 0))

1309

(do ((i 3 (+ i 2)))

1310

((>= i (- len 2)) penalty)

1311

(when (and (= (mod i 2) 1) ; for dark module

1312

(= (mod (nth i rlength) 3) 0)

1313

(let ((fact (floor (nth i rlength) 3)))

1314

;; 1:1:3:1:1

1315

(when (= fact

1316

(nth (- i 2) rlength)

1317

(nth (- i 1) rlength)

1318

(nth (+ i 1) rlength)

1319

(nth (+ i 2) rlength))

1320

(cond

1321

((<= (- i 3) 0) (incf penalty n3))

1322

((>= (+ i 4) len) (incf penalty n3))

1323

((>= (nth (- i 3) rlength) (* 4 fact)) (incf penalty n3))

1324

((>= (nth (+ i 3) rlength) (* 4 fact)) (incf penalty n3))))))))))

1325

1326

(defun evaluate-feature-2 (matrix modules)

1327

"block m * n of modules in same color. N2 * (m-1) * (n-1) points, N2=3"

1328

(let ((n2 3)

1329

(penalty 0)

1330

(bcount 0))

1331

(dotimes (i (- modules 1) penalty)

1332

(dotimes (j (- modules 1))

1333

(when (dark-module-p matrix i j)

1334

(incf bcount))

1335

(when (dark-module-p matrix (+ i 1) j)

1336

(incf bcount))

1337

(when (dark-module-p matrix i (+ j 1))

1338

(incf bcount))

1339

(when (dark-module-p matrix (+ i 1) (+ j 1))

1340

(incf bcount))

1341

(when (or (= bcount 0) (= bcount 4))

1342

(incf penalty n2))))))

1343

1344

(defclass qr-symbol ()

1345

((matrix :initform nil :initarg :matrix :reader matrix

1346

:documentation "qr code symbol as matrix")

1347

(modules :initform nil :initarg :modules :reader modules

1348

:documentation "qr code symbol modules")))

1349

1350

(defmethod print-object ((symbol qr-symbol) stream)

1351

(fresh-line stream)

1352

(with-slots (matrix modules) symbol

1353

(format stream "qr symbol ~A x ~A:~%" modules modules)

1354

(dotimes (i modules)

1355

(dotimes (j modules)

1356

(if (dark-module-p matrix i j)

1357

(format stream "1 ")

1358

(format stream "0 ")))

1359

(format stream "~%"))))

1360

1361

;;; FIXME: other encodings???

1362

(defun ascii->bytes (text)

1363

(map 'list #'char-code text))

1364

1365

(defun bytes->input (bytes version level mode)

1366

(setf version (min (max version 1) 40))

1367

(let ((input (make-instance 'qr-input :bytes bytes :version version

1368

:ec-level level :mode mode)))

1369

(data-encoding input)

1370

(ec-coding input)

1371

(structure-message input)

1372

(module-placement input)

1373

input))

1374

1375

(defun input->symbol (input)

1376

"encode qr symbol from a qr-input"

1377

(multiple-value-bind (matrix mask-ref)

1378

(data-masking input)

1379

(declare (ignore mask-ref))

1380

(let ((modules (matrix-modules (version input))))

1381

(make-instance 'qr-symbol :matrix matrix :modules modules))))

1382

1383

(defun encode-symbol-bytes (bytes &key (version 1) (level :level-m) (mode nil))

1384

"encode final qr symbol from BYTES list"

1385

(let ((input (bytes->input bytes version level mode)))

1386

(log:debug! (format nil "version: ~A; segments: ~A~%" (version input)

1387

(segments input)))

1388

(input->symbol input)))

1389

1390

;;;-----------------------------------------------------------------------------

1391

;;; One Ring to Rule Them All, One Ring to Find Them,

1392

;;; One Ring to Bring Them All and In the Darkness Blind Them:

1393

;;; This function wraps all we need.

1394

;;;-----------------------------------------------------------------------------

1395

;; (sdebug :dbg-input)

1396

(defun encode-symbol (text &key (version 1) (level :level-m) (mode nil))

1397

"encode final qr symbol, unless you know what you are doing, leave MODE NIL"

1398

(let ((bytes (ascii->bytes text)))

1399

(encode-symbol-bytes bytes :version version :level level :mode mode)))

1400

1401

;;; Table 1 - Codeword capacity of all versions of QR Code 2005

1402

;;; excluding Micro QR Code, varies between version

1403

(defvar *codeword-capacity-table*

1404

#2A((-1 -1 -1 -1 -1 -1) ; 0, no such version

1405

(21 202 31 208 26 0) (25 235 31 359 44 7)

1406

(29 243 31 567 70 7) (33 251 31 807 100 7)

1407

(37 259 31 1079 134 7) (41 267 31 1383 172 7)

1408

(45 390 67 1568 196 0) (49 398 67 1936 242 0)

1409

(53 406 67 2336 292 0) (57 414 67 2768 346 0) ; Version 10

1410

(61 422 67 3232 404 0) (65 430 67 3728 466 0)

1411

(69 438 67 4256 532 0) (73 611 67 4651 581 3)

1412

(77 619 67 5243 655 3) (81 627 67 5867 733 3)

1413

(85 635 67 6523 815 3) (89 643 67 7211 901 3)

1414

(93 651 67 7931 991 3) (97 659 67 8683 1085 3) ; Version 20

1415

(101 882 67 9252 1156 4) (105 890 67 10068 1258 4)

1416

(109 898 67 10916 1364 4) (113 906 67 11796 1474 4)

1417

(117 914 67 12708 1588 4) (121 922 67 13652 1706 4)

1418

(125 930 67 14628 1828 4) (129 1203 67 15371 1921 3)

1419

(133 1211 67 16411 2051 3) (137 1219 67 17483 2185 3) ; Version 30

1420

(141 1227 67 18587 2323 3) (145 1235 67 19723 2465 3)

1421

(149 1243 67 20891 2611 3) (153 1251 67 22091 2761 3)

1422

(157 1574 67 23008 2876 0) (161 1582 67 24272 3034 0)

1423

(165 1590 67 25568 3196 0) (169 1598 67 26896 3362 0)

1424

(173 1606 67 28256 3532 0) (177 1614 67 29648 3706 0)) ; Version 40

1425

"Number of modules (as version increases, 4 modules added) A | Function pattern

1426

modules B | Format and Version information modules C | Data modules (A^2-B-C) |

1427

Data capacity codewords (bytes, including ecc codewords) | Remainder bits.")

1428

(defun codeword-capacity (version)

1429

"codeword: data word + ecc word"

1430

(aref *codeword-capacity-table* version 4))

1431

(defun matrix-modules (version)

1432

(aref *codeword-capacity-table* version 0))

1433

(defun remainder-bits (version)

1434

(aref *codeword-capacity-table* version 5))

1435

1436

(defun mode->index (mode)

1437

(case mode

1438

(:numeric 0)

1439

(:alnum 1)

1440

(:byte 2)

1441

(:kanji 3)))

1442

1443

(deftype ecc-level ()

1444

'(member :level-l :level-m :level-q :level-h))

1445

(defun level->index (level)

1446

(case level

1447

(:level-l 0)

1448

(:level-m 1)

1449

(:level-q 2)

1450

(:level-h 3)))

1451

1452

;;; (Part I of) Table 9 - Number of Error Correction Codewords (bytes)

1453

;;; varies between version and level

1454

(defvar *ecc-codewords-table*

1455

;; (:level-l :level-m :level-q :level-h)

1456

#2A((-1 -1 -1 -1) ;; 0, no such version

1457

(7 10 13 17) (10 16 22 28) (15 26 36 44)

1458

(20 36 52 64) (26 48 72 88) (36 64 96 112)

1459

(40 72 108 130) (48 88 132 156) (60 110 160 192)

1460

(72 130 192 224) (80 150 224 264) (96 176 260 308)

1461

(104 198 288 352) (120 216 320 384) (132 240 360 432)

1462

(144 280 408 480) (168 308 448 532) (180 338 504 588)

1463

(196 364 546 650) (224 416 600 700) (224 442 644 750)

1464

(252 476 690 816) (270 504 750 900) (300 560 810 960)

1465

(312 588 870 1050) (336 644 952 1110) (360 700 1020 1200)

1466

(390 728 1050 1260) (420 784 1140 1350) (450 812 1200 1440)

1467

(480 868 1290 1530) (510 924 1350 1620) (540 980 1440 1710)

1468

(570 1036 1530 1800) (570 1064 1590 1890) (600 1120 1680 1980)

1469

(630 1204 1770 2100) (660 1260 1860 2220) (720 1316 1950 2310)

1470

(750 1372 2040 2430))) ;; version 1 ~ 40

1471

(defun ecc-words-capacity (version level)

1472

(aref *ecc-codewords-table* version (level->index level)))

1473

(defun data-words-capacity (version level)

1474

(- (codeword-capacity version) (ecc-words-capacity version level)))

1475

1476

;;; (Part II of) Table 9 - Error Correction blocks

1477

;;; varies between version and level

1478

(defvar *ecc-blocks*

1479

;; (version, level) =>

1480

;; (# of ec codewords for each blk, # of blk 1, # of data words for blk 1,

1481

   ;;                                    # of blk 2, # of data words for blk 2)

1482

;; :level-l :level-m :level-q :level-h

1483

   #3A(((0  0 0  0 0)     (0  0 0  0 0)    (0  0 0  0 0)    (0  0 0 0 0))     ; no such version

1484

       ((7  1 19 0 0)     (10 1 16 0 0)    (13 1 13 0 0)    (17 1 9 0 0))     ; Version 1

1485

((10 1 34 0 0) (16 1 28 0 0) (22 1 22 0 0) (28 1 16 0 0))

1486

((15 1 55 0 0) (26 1 44 0 0) (18 2 17 0 0) (22 2 13 0 0))

1487

((20 1 80 0 0) (18 2 32 0 0) (26 2 24 0 0) (16 4 9 0 0))

1488

       ((26 1 108 0 0)    (24 2 43 0 0)    (18 2 15 2 16)   (22 2 11 2 12))   ; Version 5

1489

((18 2 68 0 0) (16 4 27 0 0) (24 4 19 0 0) (28 4 15 0 0))

1490

((20 2 78 0 0) (18 4 31 0 0) (18 2 14 4 15) (26 4 13 1 14))

1491

((24 2 97 0 0) (22 2 38 2 39) (22 4 18 2 19) (26 4 14 2 15))

1492

((30 2 116 0 0) (22 3 36 2 37) (20 4 16 4 17) (24 4 12 4 13))

1493

       ((18 2 68 2 69)    (26 4 43 1 44)   (24 6 19 2 20)   (28 6 15 2 16))   ; Version 10

1494

((20 4 81 0 0) (30 1 50 4 51) (28 4 22 4 23) (24 3 12 8 13))

1495

((24 2 92 2 93) (22 6 36 2 37) (26 4 20 6 21) (28 7 14 4 15))

1496

((26 4 107 0 0) (22 8 37 1 38) (24 8 20 4 21) (22 12 11 4 12))

1497

((30 3 115 1 116) (24 4 40 5 41) (20 11 16 5 17) (24 11 12 5 13))

1498

       ((22 5 87 1 88)    (24 5 41 5 42)   (30 5 24 7 25)   (24 11 12 7 13))  ; Version 15

1499

((24 5 98 1 99) (28 7 45 3 46) (24 15 19 2 20) (30 3 15 13 16))

1500

((28 1 107 5 108) (28 10 46 1 47) (28 1 22 15 23) (28 2 14 17 15))

1501

((30 5 120 1 121) (26 9 43 4 44) (28 17 22 1 23) (28 2 14 19 15))

1502

((28 3 113 4 114) (26 3 44 11 45) (26 17 21 4 22) (26 9 13 16 14))

1503

       ((28 3 107 5 108)  (26 3 41 13 42)  (30 15 24 5 25)  (28 15 15 10 16)) ; Version 20

1504

((28 4 116 4 117) (26 17 42 0 0) (28 17 22 6 23) (30 19 16 6 17))

1505

((28 2 111 7 112) (28 17 46 0 0) (30 7 24 16 25) (24 34 13 0 0))

1506

((30 4 121 5 122) (28 4 47 14 48) (30 11 24 14 25) (30 16 15 14 16))

1507

((30 6 117 4 118) (28 6 45 14 46) (30 11 24 16 25) (30 30 16 2 17))

1508

       ((26 8 106 4 107)  (28 8 47 13 48)  (30 7 24 22 25)  (30 22 15 13 16)) ; Version 25

1509

((28 10 114 2 115) (28 19 46 4 47) (28 28 22 6 23) (30 33 16 4 17))

1510

((30 8 122 4 123) (28 22 45 3 46) (30 8 23 26 24) (30 12 15 28 16))

1511

((30 3 117 10 118) (28 3 45 23 46) (30 4 24 31 25) (30 11 15 31 16))

1512

((30 7 116 7 117) (28 21 45 7 46) (30 1 23 37 24) (30 19 15 26 16))

1513

((30 5 115 10 116) (28 19 47 10 48) (30 15 24 25 25) (30 23 15 25 16)) ; Version 30

1514

((30 13 115 3 116) (28 2 46 29 47) (30 42 24 1 25) (30 23 15 28 16))

1515

((30 17 115 0 0) (28 10 46 23 47) (30 10 24 35 25) (30 19 15 35 16))

1516

((30 17 115 1 116) (28 14 46 21 47) (30 29 24 19 25) (30 11 15 46 16))

1517

((30 13 115 6 116) (28 14 46 23 47) (30 44 24 7 25) (30 59 16 1 17))

1518

((30 12 121 7 122) (28 12 47 26 48) (30 39 24 14 25) (30 22 15 41 16)) ; Version 35

1519

((30 6 121 14 122) (28 6 47 34 48) (30 46 24 10 25) (30 2 15 64 16))

1520

((30 17 122 4 123) (28 29 46 14 47) (30 49 24 10 25) (30 24 15 46 16))

1521

((30 4 122 18 123) (28 13 46 32 47) (30 48 24 14 25) (30 42 15 32 16))

1522

((30 20 117 4 118) (28 40 47 7 48) (30 43 24 22 25) (30 10 15 67 16))

1523

((30 19 118 6 119) (28 18 47 31 48) (30 34 24 34 25) (30 20 15 61 16)) ; Version 40

1524

))

1525

(defun ecc-block-nums (version level)

1526

"# of ec codewords for each blk, # of blk 1, # of data words for blk 1, ..."

1527

(let ((lidx (level->index level)))

1528

(values (aref *ecc-blocks* version lidx 0)

1529

(aref *ecc-blocks* version lidx 1)

1530

(aref *ecc-blocks* version lidx 2)

1531

(aref *ecc-blocks* version lidx 3)

1532

(aref *ecc-blocks* version lidx 4))))

1533

1534

(defun minimum-version (init-version nbytes level)

1535

"minimum version that can hold NBYTES data words, or INIT-VERSION if bigger"

1536

(do ((v init-version (1+ v)))

1537

((> v 40) nil)

1538

(when (>= (data-words-capacity v level) nbytes)

1539

(return-from minimum-version v))))

1540

1541

(defun version-range (version)

1542

(cond

1543

((<= 1 version 9) 0)

1544

((<= 10 version 26) 1)

1545

((<= 27 version 40) 2)))

1546

1547

;;; Table 3 - Number of bits in character count indicator for QR Code 2005

1548

(defvar *char-count-indicator*

1549

;; :numeric :alnum :byte :kanji

1550

#2A((10 9 8 8) ; version-range 0

1551

(12 11 16 10) ; version-range 1

1552

(14 13 16 12))) ; version-range 2

1553

(defun char-count-bits (version mode)

1554

(let ((i (version-range version))

1555

(j (mode->index mode)))

1556

(aref *char-count-indicator* i j)))

1557

1558

;;; Table E.1 - Row/column coordinates of center modules of alignment patterns

1559

;;; varies between versions

1560

(defvar *align-coord-table*

1561

#2A((0 ()) ; 0, no such version

1562

       (0  ())                       (1  (6 18))                   (1  (6 22))

1563

       (1  (6 26))                   (1  (6 30))                   (1  (6 34))

1564

       (6  (6 22 38))                (6  (6 24 42))                (6  (6 26 46))

1565

       (6  (6 28 50))                (6  (6 30 54))                (6  (6 32 58))

1566

       (6  (6 34 62))                (13 (6 26 46 66))             (13 (6 26 48 70))

1567

       (13 (6 26 50 74))             (13 (6 30 54 78))             (13 (6 30 56 82))

1568

       (13 (6 30 58 86))             (13 (6 34 62 90))             (22 (6 28 50 72 94))

1569

       (22 (6 26 50 74 98))          (22 (6 30 54 78 102))         (22 (6 28 54 80 106))

1570

       (22 (6 32 58 84 110))         (22 (6 30 58 86 114))         (22 (6 34 62 90 118))

1571

       (33 (6 26 50 74 98 122))      (33 (6 30 54 78 102 126))     (33 (6 26 52 78 104 130))

1572

       (33 (6 30 56 82 108 134))     (33 (6 34 60 86 112 138))     (33 (6 30 58 86 114 142))

1573

       (33 (6 34 62 90 118 146))     (46 (6 30 54 78 102 126 150)) (46 (6 24 50 76 102 128 154))

1574

       (46 (6 28 54 80 106 132 158)) (46 (6 32 58 84 110 136 162)) (46 (6 26 54 82 110 138 166))

1575

(46 (6 30 58 86 114 142 170)))

1576

"# of Alignment Patterns, row/column coordinates of center modules.")

1577

(defun valid-center-p (x y modules)

1578

"The alignment center module is not in Finder Patterns."

1579

(not (or (and (<= 0 x 8) (<= 0 y 8)) ; upleft finder pattern

1580

(and (<= 0 x 8)

1581

(<= (- modules 8) y (- modules 1))) ; upright finder pattern

1582

(and (<= (- modules 8) x (- modules 1))

1583

(<= 0 y 8)))))

1584

(defun align-centers (version)

1585

"list of all valid alignment pattern center modules under VERSION"

1586

(let* ((modules (matrix-modules version))

1587

(coords (aref *align-coord-table* version 1))

1588

(len (length coords))

1589

(centers nil))

1590

(dotimes (i len)

1591

(loop for j from i to (- len 1) do

1592

(let ((x (nth i coords))

1593

(y (nth j coords)))

1594

(when (valid-center-p x y modules)

1595

(push (list x y) centers))

1596

(unless (= x y)

1597

(when (valid-center-p y x modules)

1598

(push (list y x) centers))))))

1599

centers))

1600

1601

(defun mask-condition (indicator)

1602

(lambda (i j)

1603

(case indicator

1604

;; (i + j) mod 2 == 0

1605

(0 (= (mod (+ i j) 2) 0))

1606

;; i mod 2 == 0

1607

(1 (= (mod i 2) 0))

1608

;; j mod 3 == 0

1609

(2 (= (mod j 3) 0))

1610

;; (i + j) mod 3 == 0

1611

(3 (= (mod (+ i j) 3) 0))

1612

;; ((i/2) + (j/3)) mod 2 == 0

1613

(4 (= (mod (+ (floor i 2) (floor j 3)) 2) 0))

1614

;; (i*j) mod 2 + (i*j) mod 3 == 0

1615

(5 (= (+ (mod (* i j) 2) (mod (* i j) 3)) 0))

1616

;; ((i*j) mod 2 + (i*j) mod 3)) mod 2 == 0

1617

(6 (= (mod (+ (mod (* i j) 2) (mod (* i j) 3)) 2) 0))

1618

;; ((i+j) mod 2 + (i*j) mod 3)) mod 2 == 0

1619

(7 (= (mod (+ (mod (+ i j) 2) (mod (* i j) 3)) 2) 0)))))

1620

1621

(defvar *ecc-level-indicator* #((0 1) (0 0) (1 1) (1 0))

1622

":level-l :level-m :level-q :level-h")

1623

(defun level-indicator (level)

1624

(aref *ecc-level-indicator* (level->index level)))

1625

(defvar *mask-pattern-reference*

1626

#((0 0 0) (0 0 1) (0 1 0) (0 1 1)

1627

(1 0 0) (1 0 1) (1 1 0) (1 1 1)))

1628

(defun mask-pattern-ref (ind)

1629

(aref *mask-pattern-reference* ind))

1630

1631

;;; png backend for QR code symbol

1632

1633

(defun set-color (pngarray x y color)

1634

(setf (aref pngarray x y 0) color)

1635

(setf (aref pngarray x y 1) color)

1636

(setf (aref pngarray x y 2) color))

1637

1638

(defun qr-symbol-to-png (symbol pixsize margin)

1639

"return the qr symbol written into a PNG object with PIXSIZE

1640

pixels for each module, and MARGIN pixels on all four sides"

1641

(with-slots (matrix modules) symbol

1642

(let* ((size (+ (* modules pixsize) (* margin 2)))

1643

(qrpng (make-instance 'png :width size :height size))

1644

(qrarray (dat/png::data-array qrpng)))

1645

(dotimes (x size)

1646

(dotimes (y size)

1647

(if (and (<= margin x (- size margin 1))

1648

(<= margin y (- size margin 1)))

1649

(let ((i (floor (- x margin) pixsize))

1650

(j (floor (- y margin) pixsize)))

1651

(if (dark-module-p matrix i j)

1652

(set-color qrarray x y 0)

1653

(set-color qrarray x y 255)))

1654

;; quiet zone

1655

(set-color qrarray x y 255))))

1656

qrpng)))

1657

1658

(defun qr-encode-png (text &key (path "qrcode.png") (version 1) (level :level-m)

1659

(mode nil) (pixsize 9) (margin 8))

1660

(let ((symbol (encode-symbol text :version version :level level :mode mode)))

1661

(write-png (qr-symbol-to-png symbol pixsize margin) path)))

1662

1663

(defmethod serialize ((self string) (format (eql :qrcode)) &key path (version 1) (level :level-m))

1664

(declare (ignore format))

1665

(qr-encode-png self :path path :version version :level level))

1666

1667

(defun qr-encode-png-stream (text stream &key (version 1) (level :level-m)

1668

(mode nil) (pixsize 9) (margin 8))

1669

(let ((symbol (encode-symbol text :version version :level level :mode mode)))

1670

(write-png-stream (qr-symbol-to-png symbol pixsize margin) stream)))

1671

1672

(defun qr-encode-png-bytes (bytes &key (fpath "kanji.png") (version 1)

1673

(level :level-m) (mode nil) (pixsize 9) (margin 8))

1674

(let ((symbol (encode-symbol-bytes bytes :version version :level level

1675

:mode mode)))

1676

(write-png (qr-symbol-to-png symbol pixsize margin) fpath)))

1677

1678

(defun qr-encode-png-bytes-stream (bytes stream &key (version 1) (level :level-m)

1679

(mode nil) (pixsize 9) (margin 8))

1680

(let ((symbol (encode-symbol-bytes bytes :version version :level level

1681

:mode mode)))

1682

(write-png-stream (qr-symbol-to-png symbol pixsize margin) stream)))