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 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284
|
;;; 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)))))))
;;
;; 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-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")
|