;;; cl-pdf copyright 2002-2003 Marc Battyani see license.txt for the details ;;; You can reach me at marc.battyani@fractalconcept.com or marc@battyani.net ;;; The homepage of cl-pdf is here: http://www.fractalconcept.com/asp/html/cl-pdf.html ;; code 128 barcode from Lars Rustemeier (in-package #:pdf) ;; ;; Utils ;; (defun group (string n) (when (zerop n) (error "zero length")) (loop with length = (length string) for i from 0 below length by n collect (subseq string i (min (+ i n) length)))) ;; ;; Logic Layer ;; ;; Format: ;; [Value] [Code A] [Code B] [Code C] [Pattern (B S B S B S)] (defparameter *table* '((0 #\space #\space "00" 2 -1 2 -2 2 -2) (1 #\! #\! "01" 2 -2 2 -1 2 -2) (2 #\" #\" "02" 2 -2 2 -2 2 -1) (3 #\# #\# "03" 1 -2 1 -2 2 -3) (4 #\$ #\$ "04" 1 -2 1 -3 2 -2) (5 #\% #\% "05" 1 -3 1 -2 2 -2) (6 #\& #\& "06" 1 -2 2 -2 1 -3) (7 #\' #\' "07" 1 -2 2 -3 1 -2) (8 #\( #\( "08" 1 -3 2 -2 1 -2) (9 #\) #\) "09" 2 -2 1 -2 1 -3) (10 #\* #\* "10" 2 -2 1 -3 1 -2) (11 #\+ #\+ "11" 2 -3 1 -2 1 -2) (12 #\, #\, "12" 1 -1 2 -2 3 -2) (13 #\- #\- "13" 1 -2 2 -1 3 -2) (14 #\. #\. "14" 1 -2 2 -2 3 -1) (15 #\/ #\/ "15" 1 -1 3 -2 2 -2) (16 #\0 #\0 "16" 1 -2 3 -1 2 -2) (17 #\1 #\1 "17" 1 -2 3 -2 2 -1) (18 #\2 #\2 "18" 2 -2 3 -2 1 -1) (19 #\3 #\3 "19" 2 -2 1 -1 3 -2) (20 #\4 #\4 "20" 2 -2 1 -2 3 -1) (21 #\5 #\5 "21" 2 -1 3 -2 1 -2) (22 #\6 #\6 "22" 2 -2 3 -1 1 -2) (23 #\7 #\7 "23" 3 -1 2 -1 3 -1) (24 #\8 #\8 "24" 3 -1 1 -2 2 -2) (25 #\9 #\9 "25" 3 -2 1 -1 2 -2) (26 #\: #\: "26" 3 -2 1 -2 2 -1) (27 #\; #\; "27" 3 -1 2 -2 1 -2) (28 #\< #\< "28" 3 -2 2 -1 1 -2) (29 #\= #\= "29" 3 -2 2 -2 1 -1) (30 #\> #\> "30" 2 -1 2 -1 2 -3) (31 #\? #\? "31" 2 -1 2 -3 2 -1) (32 #\@ #\@ "32" 2 -3 2 -1 2 -1) (33 #\A #\A "33" 1 -1 1 -3 2 -3) (34 #\B #\B "34" 1 -3 1 -1 2 -3) (35 #\C #\C "35" 1 -3 1 -3 2 -1) (36 #\D #\D "36" 1 -1 2 -3 1 -3) (37 #\E #\E "37" 1 -3 2 -1 1 -3) (38 #\F #\F "38" 1 -3 2 -3 1 -1) (39 #\G #\G "39" 2 -1 1 -3 1 -3) (40 #\H #\H "40" 2 -3 1 -1 1 -3) (41 #\I #\I "41" 2 -3 1 -3 1 -1) (42 #\J #\J "42" 1 -1 2 -1 3 -3) (43 #\K #\K "43" 1 -1 2 -3 3 -1) (44 #\L #\L "44" 1 -3 2 -1 3 -1) (45 #\M #\M "45" 1 -1 3 -1 2 -3) (46 #\N #\N "46" 1 -1 3 -3 2 -1) (47 #\O #\O "47" 1 -3 3 -1 2 -1) (48 #\P #\P "48" 3 -1 3 -1 2 -1) (49 #\Q #\Q "49" 2 -1 1 -3 3 -1) (50 #\R #\R "50" 2 -3 1 -1 3 -1) (51 #\S #\S "51" 2 -1 3 -1 1 -3) (52 #\T #\T "52" 2 -1 3 -3 1 -1) (53 #\U #\U "53" 2 -1 3 -1 3 -1) (54 #\V #\V "54" 3 -1 1 -1 2 -3) (55 #\W #\W "55" 3 -1 1 -3 2 -1) (56 #\X #\X "56" 3 -3 1 -1 2 -1) (57 #\Y #\Y "57" 3 -1 2 -1 1 -3) (58 #\Z #\Z "58" 3 -1 2 -3 1 -1) (59 #\[ #\[ "59" 3 -3 2 -1 1 -1) (60 #\\ #\\ "60" 3 -1 4 -1 1 -1) (61 #\] #\] "61" 2 -2 1 -4 1 -1) (62 #\^ #\^ "62" 4 -3 1 -1 1 -1) (63 #\_ #\_ "63" 1 -1 1 -2 2 -4) (64 :NUL #\` "64" 1 -1 1 -4 2 -2) (65 :SOH #\a "65" 1 -2 1 -1 2 -4) (66 :STX #\b "66" 1 -2 1 -4 2 -1) (67 :ETX #\c "67" 1 -4 1 -1 2 -2) (68 :EOT #\d "68" 1 -4 1 -2 2 -1) (69 :ENQ #\e "69" 1 -1 2 -2 1 -4) (70 :ACK #\f "70" 1 -1 2 -4 1 -2) (71 :BEL #\g "71" 1 -2 2 -1 1 -4) (72 :BS #\h "72" 1 -2 2 -4 1 -1) (73 :HT #\i "73" 1 -4 2 -1 1 -2) (74 :LF #\j "74" 1 -4 2 -2 1 -1) (75 :VT #\k "75" 2 -4 1 -2 1 -1) (76 :FF #\l "76" 2 -2 1 -1 1 -4) (77 :CR #\m "77" 4 -1 3 -1 1 -1) (78 :SO #\n "78" 2 -4 1 -1 1 -2) (79 :SI #\o "79" 1 -3 4 -1 1 -1) (80 :DLE #\p "80" 1 -1 1 -2 4 -2) (81 :DC1 #\q "81" 1 -2 1 -1 4 -2) (82 :DC2 #\r "82" 1 -2 1 -2 4 -1) (83 :DC3 #\s "83" 1 -1 4 -2 1 -2) (84 :DC4 #\t "84" 1 -2 4 -1 1 -2) (85 :NAK #\u "85" 1 -2 4 -2 1 -1) (86 :SYN #\v "86" 4 -1 1 -2 1 -2) (87 :ETB #\w "87" 4 -2 1 -1 1 -2) (88 :CAN #\x "88" 4 -2 1 -2 1 -1) (89 :EM #\y "89" 2 -1 2 -1 4 -1) (90 :SUB #\z "90" 2 -1 4 -1 2 -1) (91 :ESC #\{ "91" 4 -1 2 -1 2 -1) (92 :FS #\| "92" 1 -1 1 -1 4 -3) (93 :GS #\} "93" 1 -1 1 -3 4 -1) (94 :RS #\~ "94" 1 -3 1 -1 4 -1) (95 :US :DEL "95" 1 -1 4 -1 1 -3) (96 :FNC-3 :FNC-3 "96" 1 -1 4 -3 1 -1) (97 :FNC-2 :FNC-2 "97" 4 -1 1 -1 1 -3) (98 :SHIFT :SHIFT "98" 4 -1 1 -3 1 -1) (99 :CODE-C :CODE-C "99" 1 -1 3 -1 4 -1) (100 :CODE-B :FNC-4 :CODE-B 1 -1 4 -1 3 -1) (101 :FNC-4 :CODE-A :CODE-A 3 -1 1 -1 4 -1) (102 :FNC-1 :FNC-1 :FNC-1 4 -1 1 -1 3 -1) (103 :START-A :START-A :START-A 2 -1 1 -4 1 -2) (104 :START-B :START-B :START-B 2 -1 1 -2 1 -4) (105 :START-C :START-C :START-C 2 -1 1 -2 3 -2) (106 :STOP :STOP :STOP 2 -3 3 -1 1 -1 2))) (defconstant +magic-modulo-number+ 103) (defun build-char-ht (lst hpred key-selector val-selector) (let ((ht (make-hash-table :test hpred))) (dolist (e lst) (setf (gethash (funcall key-selector e) ht) (funcall val-selector e))) ht)) (defparameter *table-h* (build-char-ht *table* #'eql #'first #'cdr)) (defparameter *table-a* (build-char-ht *table* #'eql #'second #'(lambda (e) (cons (first e) (cddddr e))))) (defparameter *table-b* (build-char-ht *table* #'eql #'third #'(lambda (e) (cons (first e) (cddddr e))))) (defparameter *table-c* (build-char-ht *table* #'equal #'fourth #'(lambda (e) (cons (first e) (cddddr e))))) ;; ;; Calulate checksum ;; (defun code128-checksum (chars) (mod (do ((vals (cdr chars) (cdr vals)) (factor 1 (+ factor 1)) (chksum (first chars) (+ chksum (* (car vals) factor)))) ((null vals) chksum)) +magic-modulo-number+)) ;; ;; Generic ;; (defun code128-n-raw (string start s-table getter) (let ((chars-and-bars (cons (gethash start s-table) (map 'list #'(lambda (s) (gethash s s-table)) string)))) (let* ((chars (mapcar #'car chars-and-bars)) (bars (mapcar #'cdr chars-and-bars)) (chksum (code128-checksum chars)) (chk-char-bar (cdr (gethash (funcall getter (gethash chksum *table-h*)) s-table))) (stop (cdr (gethash :STOP s-table)))) (append bars (list chk-char-bar stop))))) ;; ;; Chars and control codes ;; (defun code128-a (text) (code128-n-raw text :START-A *table-a* #'first)) ;; ;; Full printable ascii ;; (defun code128-b (text) (code128-n-raw text :START-B *table-b* #'second)) ;; ;; Compact digits ;; (defun code128-c (text) (code128-n-raw (group text 2) :START-C *table-c* #'third)) ;; ;; Calculate width of barcode in units ;; (defun unit-width (lst) ;;(reduce + 0 (map (lambda (e) (reduce + 0 e)) (map second lst)))) (reduce #'+ (mapcar #'(lambda (e) (reduce #'+ (mapcar #'abs e))) lst))) ;; ;; Drawing (Presentation Layer) ;; (defun draw-bar-segment (line-height line-width black) (with-saved-state (when (plusp black) (rectangle 0 0 (* black line-width) (- line-height)) (fill-path))) (translate (abs (* black line-width)) 0)) (defun draw-bars (bars line-height line-width &optional (start-stop-factor 0)) (let ((l (length bars))) (do* ((bars bars (cdr bars)) (bar (car bars) (car bars)) (i 0 (1+ i))) ((null bars) nil) (dolist (segment bar) (let ((line-height (if (or (= i 0) (= i (- l 1))) (* line-height (+ 1 start-stop-factor)) line-height))) (draw-bar-segment line-height line-width segment)))))) (defun draw-chars (string line-height line-width font font-size segs-per-char) (with-saved-state (translate (* 11 line-width) (- (+ line-height font-size))) (set-font font font-size) (loop for char across string do (with-saved-state (in-text-mode (show-char char))) (translate (* segs-per-char line-width) 0)))) ;; ;; Autoselect's mode based on content ;; ;; One could spend a lot of time on making really smart (Switching ;; between alphabets on the fly etc). I fear that for more advanced ;; uses it is better to let the user specify the token list ;; manually. Or build utils on top of this file's functionality. There ;; simply are too many border cases for this to make me feel right ;; about a totally automatic approach. (defun draw-bar-code128 (string x y &key (font (get-font)) (font-size 5) (start-stop-factor 0.3) (height 100) (width 400) (show-string t) (segs-per-char 11 segs-per-char-p)) (let ((dispatch #'code128-b)) (when (and (evenp (length string))(every #'digit-char-p string)) (unless segs-per-char-p (setf segs-per-char 5.5)) (setf dispatch #'code128-c)) (with-saved-state (translate x y) (set-line-width 0) (let* ((bars (funcall dispatch string)) (unit-w (unit-width bars)) (line-width (/ width unit-w)) (line-height height)) (with-saved-state (draw-bars bars line-height line-width start-stop-factor)) (when show-string (with-saved-state (draw-chars string line-height line-width font font-size segs-per-char))))))) (defun draw-qr-code (matrix x y &key (point-size 2)) "Draws a quadratic 2D MATRIX at X, Y as a QR code. The matrix elements can be 0 or 1, or :DARK, :FDARK, :LIGHT, :FLIGHT (so that CL-QRENCODE:ENCODE-SYMBOL results can be easily used). POINT-SIZE gives the size per pixel." (let* ((dims (array-dimensions matrix)) (size (first dims)) (lin-total (make-array (array-total-size matrix) :displaced-to matrix :displaced-index-offset 0))) (when (or (/= 2 (length dims)) (/= size (second dims))) (error "~s is not a quadratic matrix" matrix)) ;; (flet ((dark? (x) (or (eql x 1) (eq x :dark) (eq x :fdark)))) (with-saved-state (translate x y) ;; Axis goes down! (scale point-size (- point-size)) (loop for x below size for linear = (make-array size :displaced-to lin-total :displaced-index-offset (* x size)) do (let ((y 0)) (translate 1 0) ;; Do run-length encoding to reduce the PDF size (loop while (< y size) for dark-start = (position-if #'dark? linear :start y) while dark-start do (let* ((dark-end (position-if-not #'dark? linear :start dark-start)) (end2 (or dark-end size))) (rectangle 0 dark-start 1 (- end2 dark-start)) (setf y (1+ end2)))) (fill-path))))))) ;; ;; Pres test code ;; #+nil (defun tester (str &optional (to-file "/tmp/foobar.pdf")) (pdf:with-document () (pdf:with-page () (pdf:with-outline-level ((format nil "BarCodes Sample") (pdf:register-page-reference)) (pdf:with-saved-state (pdf:translate -150 -400) (pdf:rotate 90) (pdf:translate 500 -300) (pdf:rotate 5) (draw-qr-code #2a((1 1 1 1 1 1 1 0 0 1 1 0 0 0 1 1 1 1 1 1 1) (1 0 0 0 0 0 1 0 0 1 0 0 0 0 1 0 0 0 0 0 1) (1 0 1 1 1 0 1 0 0 1 0 1 0 0 1 0 1 1 1 0 1) (1 0 1 1 1 0 1 0 0 0 0 1 0 0 1 0 1 1 1 0 1) (1 0 1 1 1 0 1 0 0 1 0 0 1 0 1 0 1 1 1 0 1) (1 0 0 0 0 0 1 0 1 1 0 1 1 0 1 0 0 0 0 0 1) (1 1 1 1 1 1 1 0 1 0 1 0 1 0 1 1 1 1 1 1 1) (0 0 0 0 0 0 0 0 0 1 0 1 1 0 0 0 0 0 0 0 0) (1 0 0 1 0 1 1 0 1 0 0 0 0 1 0 1 0 0 0 0 0) (0 0 0 0 1 1 0 0 0 1 0 0 0 0 1 0 0 0 1 0 0) (1 1 0 0 0 0 1 0 0 1 1 0 1 1 0 0 0 0 0 1 1) (1 1 1 0 1 1 0 1 0 0 0 1 0 0 0 0 0 0 1 0 0) (0 0 0 1 0 1 1 1 0 0 0 0 1 0 1 0 1 1 1 0 1) (0 0 0 0 0 0 0 0 1 0 0 1 0 0 0 1 1 0 1 0 1) (1 1 1 1 1 1 1 0 0 1 0 0 0 1 0 1 0 1 1 0 0) (1 0 0 0 0 0 1 0 1 1 0 1 1 1 0 1 1 1 1 0 1) (1 0 1 1 1 0 1 0 0 1 1 1 0 0 1 1 1 1 1 1 1) (1 0 1 1 1 0 1 0 1 1 1 1 0 0 0 1 0 1 0 1 1) (1 0 1 1 1 0 1 0 0 0 1 0 1 0 0 0 1 0 0 0 1) (1 0 0 0 0 0 1 0 0 1 0 0 0 1 1 1 1 1 0 0 1) (1 1 1 1 1 1 1 0 1 0 0 1 1 0 0 0 1 1 1 0 0)) 100 100) (draw-bar-code128 str 0 0 :height 300 :width 600 :start-stop-factor 0.2 :font-size 40 :show-string t)))) (pdf:write-document to-file))) #+nil (tester "CL:PDF Marc B" #P"/home/largo/char-b.pdf") #+nil (tester "012345" #P"/home/largo/char-c.pdf")