-
Notifications
You must be signed in to change notification settings - Fork 7
/
qrcode.lisp
80 lines (69 loc) · 2.65 KB
/
qrcode.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
(eval-when (:compile-toplevel :load-toplevel :execute)
(ql:quickload '("iup" "iup-cd" "cd" "lispqr")))
(defpackage #:iup-examples.qrcode
(:use #:common-lisp)
(:export #:qrcode))
(in-package #:iup-examples.qrcode)
(defvar *model*
(format nil "~A ~A IUP ~A"
(lisp-implementation-type)
(lisp-implementation-version)
(iup:version)))
(defparameter *canvas* nil)
(defun qrcode ()
(iup:with-iup ()
(let* ((canvas (iup:canvas
:rastersize "400x400"
:map_cb 'canvas-map
:unmap_cb 'canvas-unmap
:action 'canvas-redraw))
(text (iup:text
:expand :horizontal
:valuechanged_cb (lambda (handle)
(setf *model*
(iup:attribute handle :value))
(canvas-redraw *canvas* 0 0)
iup:+default+)))
(vbox (iup:vbox (list canvas text) :margin "10x10" :cmargin "10x10"))
(dialog (iup:dialog vbox :title "QR Code")))
(iup:show-xy dialog iup:+center+ iup:+center+)
(iup:main-loop))))
(defun qrcode-draw (canvas model)
(multiple-value-bind
(w h)
(cd:size canvas)
(cd:clear canvas)
(when (and model (> (length model) 0))
(let* ((matrix (lispqr:encode->matrix model :ec-level :q))
(m (array-dimension matrix 0))
(n (array-dimension matrix 1))
(i-step (/ w (1+ m)))
(j-step (/ h (1+ n))))
(loop for i below n
do (loop for j below m
do (let* ((x-min (* j j-step))
(x-max (+ x-min j-step))
(y-min (* i i-step))
(y-max (+ y-min i-step))
(cell-color (if (zerop (aref matrix j i))
cd:+white+
cd:+black+)))
(setf (cd:foreground *canvas*) cell-color)
(cd:box canvas x-min x-max y-min y-max))))))))
(defun canvas-redraw (handle x y)
(declare (ignore handle x y))
(cd:activate *canvas*)
(qrcode-draw *canvas* *model*)
(cd:flush *canvas*)
iup:+default+)
(defun canvas-map (handle)
(setf *canvas* (cd:create-canvas (iup-cd:context-iup-dbuffer) handle))
iup:+default+)
(defun canvas-unmap (handle)
(cd:kill *canvas*)
iup:+default+)
#-sbcl (qrcode)
#+sbcl
(sb-int:with-float-traps-masked
(:divide-by-zero :invalid)
(qrcode))