code128.lisp 15 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366
  1. ;; This software is Copyright (c) cage
  2. ;; cage grants you the rights to distribute
  3. ;; and use this software as governed by the terms
  4. ;; of the Lisp Lesser GNU Public License
  5. ;; (http://opensource.franz.com/preamble.html),
  6. ;; known as the LLGPL
  7. (in-package :cl-pslib-barcode)
  8. (alexandria:define-constant +code128-checksum-modulo+ 103 :test #'=)
  9. (alexandria:define-constant +code128-code-c-valid-regexp+ "[0-9][0-9]" :test #'string=)
  10. (alexandria:define-constant +code128-min-quiet-zone-abs+ 6.4 :test #'=)
  11. (alexandria:define-constant +code128-min-quiet-zone-rel+ 10 :test #'=)
  12. (alexandria:define-constant +code128-table+
  13. '((" " " " "00" (T T NIL T T NIL NIL T T NIL NIL))
  14. ("!" "!" "01" (T T NIL NIL T T NIL T T NIL NIL))
  15. ("\"" "\"" "02" (T T NIL NIL T T NIL NIL T T NIL))
  16. ("#" "#" "03" (T NIL NIL T NIL NIL T T NIL NIL NIL))
  17. ("$" "$" "04" (T NIL NIL T NIL NIL NIL T T NIL NIL))
  18. ("%" "%" "05" (T NIL NIL NIL T NIL NIL T T NIL NIL))
  19. ("&" "&" "06" (T NIL NIL T T NIL NIL T NIL NIL NIL))
  20. ("'" "'" "07" (T NIL NIL T T NIL NIL NIL T NIL NIL))
  21. ("(" "(" "08" (T NIL NIL NIL T T NIL NIL T NIL NIL))
  22. (")" ")" "09" (T T NIL NIL T NIL NIL T NIL NIL NIL))
  23. ("*" "*" "10" (T T NIL NIL T NIL NIL NIL T NIL NIL))
  24. ("+" "+" "11" (T T NIL NIL NIL T NIL NIL T NIL NIL))
  25. ("," "," "12" (T NIL T T NIL NIL T T T NIL NIL))
  26. ("-" "-" "13" (T NIL NIL T T NIL T T T NIL NIL))
  27. ("." "." "14" (T NIL NIL T T NIL NIL T T T NIL))
  28. ("/" "/" "15" (T NIL T T T NIL NIL T T NIL NIL))
  29. ("0" "0" "16" (T NIL NIL T T T NIL T T NIL NIL))
  30. ("1" "1" "17" (T NIL NIL T T T NIL NIL T T NIL))
  31. ("2" "2" "18" (T T NIL NIL T T T NIL NIL T NIL))
  32. ("3" "3" "19" (T T NIL NIL T NIL T T T NIL NIL))
  33. ("4" "4" "20" (T T NIL NIL T NIL NIL T T T NIL))
  34. ("5" "5" "21" (T T NIL T T T NIL NIL T NIL NIL))
  35. ("6" "6" "22" (T T NIL NIL T T T NIL T NIL NIL))
  36. ("7" "7" "23" (T T T NIL T T NIL T T T NIL))
  37. ("8" "8" "24" (T T T NIL T NIL NIL T T NIL NIL))
  38. ("9" "9" "25" (T T T NIL NIL T NIL T T NIL NIL))
  39. (":" ":" "26" (T T T NIL NIL T NIL NIL T T NIL))
  40. (";" ";" "27" (T T T NIL T T NIL NIL T NIL NIL))
  41. ("<" "<" "28" (T T T NIL NIL T T NIL T NIL NIL))
  42. ("=" "=" "29" (T T T NIL NIL T T NIL NIL T NIL))
  43. (">" ">" "30" (T T NIL T T NIL T T NIL NIL NIL))
  44. ("?" "?" "31" (T T NIL T T NIL NIL NIL T T NIL))
  45. ("@" "@" "32" (T T NIL NIL NIL T T NIL T T NIL))
  46. ("A" "A" "33" (T NIL T NIL NIL NIL T T NIL NIL NIL))
  47. ("B" "B" "34" (T NIL NIL NIL T NIL T T NIL NIL NIL))
  48. ("C" "C" "35" (T NIL NIL NIL T NIL NIL NIL T T NIL))
  49. ("D" "D" "36" (T NIL T T NIL NIL NIL T NIL NIL NIL))
  50. ("E" "E" "37" (T NIL NIL NIL T T NIL T NIL NIL NIL))
  51. ("F" "F" "38" (T NIL NIL NIL T T NIL NIL NIL T NIL))
  52. ("G" "G" "39" (T T NIL T NIL NIL NIL T NIL NIL NIL))
  53. ("H" "H" "40" (T T NIL NIL NIL T NIL T NIL NIL NIL))
  54. ("I" "I" "41" (T T NIL NIL NIL T NIL NIL NIL T NIL))
  55. ("J" "J" "42" (T NIL T T NIL T T T NIL NIL NIL))
  56. ("K" "K" "43" (T NIL T T NIL NIL NIL T T T NIL))
  57. ("L" "L" "44" (T NIL NIL NIL T T NIL T T T NIL))
  58. ("M" "M" "45" (T NIL T T T NIL T T NIL NIL NIL))
  59. ("N" "N" "46" (T NIL T T T NIL NIL NIL T T NIL))
  60. ("O" "O" "47" (T NIL NIL NIL T T T NIL T T NIL))
  61. ("P" "P" "48" (T T T NIL T T T NIL T T NIL))
  62. ("Q" "Q" "49" (T T NIL T NIL NIL NIL T T T NIL))
  63. ("R" "R" "50" (T T NIL NIL NIL T NIL T T T NIL))
  64. ("S" "S" "51" (T T NIL T T T NIL T NIL NIL NIL))
  65. ("T" "T" "52" (T T NIL T T T NIL NIL NIL T NIL))
  66. ("U" "U" "53" (T T NIL T T T NIL T T T NIL))
  67. ("V" "V" "54" (T T T NIL T NIL T T NIL NIL NIL))
  68. ("W" "W" "55" (T T T NIL T NIL NIL NIL T T NIL))
  69. ("X" "X" "56" (T T T NIL NIL NIL T NIL T T NIL))
  70. ("Y" "Y" "57" (T T T NIL T T NIL T NIL NIL NIL))
  71. ("Z" "Z" "58" (T T T NIL T T NIL NIL NIL T NIL))
  72. ("[" "[" "59" (T T T NIL NIL NIL T T NIL T NIL))
  73. ("\\" "\\" "60" (T T T NIL T T T T NIL T NIL))
  74. ("]" "]" "61" (T T NIL NIL T NIL NIL NIL NIL T NIL))
  75. ("^" "^" "62" (T T T T NIL NIL NIL T NIL T NIL))
  76. ("_" "_" "63" (T NIL T NIL NIL T T NIL NIL NIL NIL))
  77. ("NUL" "`" "64" (T NIL T NIL NIL NIL NIL T T NIL NIL))
  78. ("SOH" "a" "65" (T NIL NIL T NIL T T NIL NIL NIL NIL))
  79. ("STX" "b" "66" (T NIL NIL T NIL NIL NIL NIL T T NIL))
  80. ("ETX" "c" "67" (T NIL NIL NIL NIL T NIL T T NIL NIL))
  81. ("EOT" "d" "68" (T NIL NIL NIL NIL T NIL NIL T T NIL))
  82. ("ENQ" "e" "69" (T NIL T T NIL NIL T NIL NIL NIL NIL))
  83. ("ACK" "f" "70" (T NIL T T NIL NIL NIL NIL T NIL NIL))
  84. ("BEL" "g" "71" (T NIL NIL T T NIL T NIL NIL NIL NIL))
  85. ("BS" "h" "72" (T NIL NIL T T NIL NIL NIL NIL T NIL))
  86. ("HT" "i" "73" (T NIL NIL NIL NIL T T NIL T NIL NIL))
  87. ("LF" "j" "74" (T NIL NIL NIL NIL T T NIL NIL T NIL))
  88. ("VT" "k" "75" (T T NIL NIL NIL NIL T NIL NIL T NIL))
  89. ("FF" "l" "76" (T T NIL NIL T NIL T NIL NIL NIL NIL))
  90. ("CR" "m" "77" (T T T T NIL T T T NIL T NIL))
  91. ("SO" "n" "78" (T T NIL NIL NIL NIL T NIL T NIL NIL))
  92. ("SI" "o" "79" (T NIL NIL NIL T T T T NIL T NIL))
  93. ("DLE" "p" "80" (T NIL T NIL NIL T T T T NIL NIL))
  94. ("DC1" "q" "81" (T NIL NIL T NIL T T T T NIL NIL))
  95. ("DC2" "r" "82" (T NIL NIL T NIL NIL T T T T NIL))
  96. ("DC3" "s" "83" (T NIL T T T T NIL NIL T NIL NIL))
  97. ("DC4" "t" "84" (T NIL NIL T T T T NIL T NIL NIL))
  98. ("NAK" "u" "85" (T NIL NIL T T T T NIL NIL T NIL))
  99. ("SYN" "v" "86" (T T T T NIL T NIL NIL T NIL NIL))
  100. ("ETB" "w" "87" (T T T T NIL NIL T NIL T NIL NIL))
  101. ("CAN" "x" "88" (T T T T NIL NIL T NIL NIL T NIL))
  102. ("EM" "y" "89" (T T NIL T T NIL T T T T NIL))
  103. ("SUB" "z" "90" (T T NIL T T T T NIL T T NIL))
  104. ("ESC" "{" "91" (T T T T NIL T T NIL T T NIL))
  105. ("FS" "|" "92" (T NIL T NIL T T T T NIL NIL NIL))
  106. ("GS" "}" "93" (T NIL T NIL NIL NIL T T T T NIL))
  107. ("RS" "~" "94" (T NIL NIL NIL T NIL T T T T NIL))
  108. ("US" "DEL" "95" (T NIL T T T T NIL T NIL NIL NIL))
  109. ("FNC3" "FNC3" "96" (T NIL T T T T NIL NIL NIL T NIL))
  110. ("FNC2" "FNC2" "97" (T T T T NIL T NIL T NIL NIL NIL))
  111. ("SHIFT" "SHIFT" "98" (T T T T NIL T NIL NIL NIL T NIL))
  112. ("CODE-C" "CODE-C" "99" (T NIL T T T NIL T T T T NIL))
  113. ("CODE-B" "FNC4" "CODE-B" (T NIL T T T T NIL T T T NIL))
  114. ("FNC4" "CODE-A" "CODE-A" (T T T NIL T NIL T T T T NIL))
  115. ("FNC1" "FNC1" "FNC1" (T T T T NIL T NIL T T T NIL))
  116. ("START-A" "START-A" "START-A" (T T NIL T NIL NIL NIL NIL T NIL NIL))
  117. ("START-B" "START-B" "START-B" (T T NIL T NIL NIL T NIL NIL NIL NIL))
  118. ("START-C" "START-C" "START-C" (T T NIL T NIL NIL T T T NIL NIL))
  119. ("STOP" "STOP" "STOP" (T T NIL NIL NIL T T T NIL T NIL T T)))
  120. :test #'equalp)
  121. (alexandria:define-constant +shift+ "SHIFT" :test #'string=)
  122. (alexandria:define-constant +start-a+ "START-A" :test #'string=)
  123. (alexandria:define-constant +start-b+ "START-B" :test #'string=)
  124. (alexandria:define-constant +start-c+ "START-C" :test #'string=)
  125. (alexandria:define-constant +code-a+ "CODE-A" :test #'string=)
  126. (alexandria:define-constant +code-b+ "CODE-B" :test #'string=)
  127. (alexandria:define-constant +code-c+ "CODE-C" :test #'string=)
  128. (alexandria:define-constant +stop+ "STOP" :test #'string=)
  129. (alexandria:define-constant +keyword-prefix+ "$" :test #'string=)
  130. (define-condition code128-symbol-not-found (text-error)
  131. ((variant
  132. :initarg :variant
  133. :reader variant)
  134. (code-symbol
  135. :initarg :code-symbol
  136. :reader code-symbol))
  137. (:report (lambda (condition stream)
  138. (format stream "Symbol ~a (variant ~a) not found" (code-symbol condition) (variant condition)))))
  139. (define-condition code128-parse-error (text-error)
  140. ()
  141. (:report (lambda (condition stream)
  142. (format stream "Parsing error: ~a" (text condition)))))
  143. (defun find-row (pos)
  144. (nth pos +code128-table+))
  145. (defparameter *current-variant* :a)
  146. (defun lookup (key &key (variant *current-variant*))
  147. (labels ((lookup-row (row)
  148. (let ((pos (ecase variant
  149. (:a (list 0))
  150. (:b (list 1))
  151. (:c (list 2))
  152. (:any (list 0 1 2)))))
  153. (find-if #'(lambda(p) (string= (nth p row) key)) pos))))
  154. (values
  155. (position-if #'lookup-row +code128-table+)
  156. (find-if #'lookup-row +code128-table+))))
  157. (defun code128-checksum (codes-list &optional (checksum 0) (ct 0))
  158. (if codes-list
  159. (let ((val (first codes-list)))
  160. (code128-checksum (rest codes-list) (+ checksum
  161. (* val (if (= 0 ct) 1 ct)))
  162. (1+ ct)))
  163. (mod checksum +code128-checksum-modulo+)))
  164. (defmacro eval-to-keyword ((keywords str) &body not-found)
  165. `(cond
  166. ,@(mapcar #'(lambda (k) `((is-keyword-p ,k ,str)
  167. (values ,k (subseq ,str (length ,k)))))
  168. keywords)
  169. (t
  170. (values (progn ,@not-found) nil))))
  171. (defun code128-lexer (codes)
  172. (cond
  173. ((string= (char@ codes 0) +keyword-prefix+)
  174. (multiple-value-bind (keyword rest-codes)
  175. (eval-to-keyword ((+shift+ +start-a+ +start-b+ +start-c+
  176. +code-a+ +code-b+ +code-c+ +shift+)
  177. (subseq codes (length +keyword-prefix+))) +keyword-prefix+)
  178. (if rest-codes
  179. (values keyword rest-codes)
  180. (values keyword (subseq codes (length +keyword-prefix+))))))
  181. ((string= codes "")
  182. (values nil ""))
  183. (t
  184. (values (char@ codes 0) (subseq codes 1)))))
  185. (defun tokenize-all (str &optional (codes '()))
  186. (multiple-value-bind (token rest-codes)
  187. (code128-lexer str)
  188. (if token
  189. (tokenize-all rest-codes (push token codes))
  190. (reverse codes))))
  191. (defmacro valid-value-p (token codes)
  192. `(or
  193. ,@(mapcar #'(lambda (code)
  194. `(string= ,code ,token))
  195. codes)))
  196. (defun start-code->current-variant (start-code)
  197. (cond
  198. ((string= start-code +start-a+)
  199. :a)
  200. ((string= start-code +start-b+)
  201. :b)
  202. ((string= start-code +start-c+)
  203. :c)))
  204. (defun parse-code128 (tokens)
  205. (let* ((start-code (eval-to-keyword ((+start-a+ +start-b+ +start-c+) (first tokens)) nil)))
  206. (if start-code
  207. (progn
  208. (setf *current-variant* (start-code->current-variant start-code))
  209. (let ((raw-code (append (list (lookup start-code :variant :any))
  210. (parse-values-type-any (rest tokens)))))
  211. (append raw-code (list (code128-checksum raw-code) (lookup +stop+)))))
  212. (error 'code128-parse-error :text (format nil
  213. "not starting with a valid starting code (~a)"
  214. (first tokens))))))
  215. (defun parse-values-type-any (tokens)
  216. (if tokens
  217. (let ((keyword (eval-to-keyword ((+shift+ +code-a+ +code-b+ +code-c+) (first tokens)) nil))
  218. (saved-current-variant *current-variant*))
  219. (if keyword
  220. (cond
  221. ((string= keyword +shift+)
  222. (append
  223. (parse-shift-code-type-a tokens)))
  224. ((string= keyword +code-a+)
  225. (setf *current-variant* :a)
  226. (append
  227. (let ((*current-variant* saved-current-variant))
  228. (list (lookup +code-a+)))
  229. (parse-values-type-any (rest tokens))))
  230. ((string= keyword +code-b+)
  231. (setf *current-variant* :b)
  232. (append
  233. (let ((*current-variant* saved-current-variant))
  234. (list (lookup +code-b+)))
  235. (parse-values-type-any (rest tokens))))
  236. ((string= keyword +code-c+)
  237. (setf *current-variant* :c)
  238. (append
  239. (let ((*current-variant* saved-current-variant))
  240. (list (lookup +code-c+)))
  241. (parse-value-type-c (rest tokens)))))
  242. (if (eq *current-variant* :c)
  243. (parse-value-type-c tokens)
  244. (let ((lookup-val (lookup (first tokens) :variant *current-variant*)))
  245. (if lookup-val
  246. (append (list lookup-val)
  247. (parse-values-type-any (rest tokens)))
  248. (error 'code128-symbol-not-found
  249. :code-symbol (first tokens)
  250. :variant *current-variant*))))))
  251. nil))
  252. (defun parse-value-type-c (tokens)
  253. (if (>= (length tokens) 2)
  254. (progn
  255. (let ((code (concatenate 'string (first tokens) (second tokens))))
  256. (if (cl-ppcre:scan +code128-code-c-valid-regexp+ code)
  257. (append
  258. (list (lookup code :variant *current-variant*))
  259. (parse-values-type-any (subseq tokens 2)))
  260. (error 'code128-parse-error
  261. :text (format nil "Codes is not a two digits string ~a" code)))))
  262. (error 'code128-parse-error
  263. :text (format nil "Not enough digits for code type c ~a" tokens))))
  264. (defun shift-current-variant ()
  265. (if (eq *current-variant* :a)
  266. (setf *current-variant* :b)
  267. (setf *current-variant* :a)))
  268. (defmacro with-shifted-current-variant (&body body)
  269. `(let ((*current-variant* (if (eq *current-variant* :a) :b :a)))
  270. ,@body))
  271. (defun parse-shift-code-type-a (tokens)
  272. (let ((keyword (eval-to-keyword ((+shift+) (first tokens)) nil)))
  273. (if keyword
  274. (append
  275. (list (lookup +shift+))
  276. (let* ((rest-tokens (rest tokens))
  277. (lookup-val (with-shifted-current-variant
  278. (lookup (first rest-tokens) :variant *current-variant*))))
  279. (if lookup-val
  280. (append (list lookup-val)
  281. (parse-values-type-any (rest rest-tokens)))
  282. (error 'code128-symbol-not-found :code-symbol (first tokens) :variant :b))))
  283. (error 'code128-parse-error :text (format nil
  284. "~a expected ~a got instead"
  285. +shift+
  286. (first tokens))))))
  287. (defclass code128 (barcode)
  288. ((code
  289. :initform '()
  290. :accessor code)))
  291. (defgeneric bars-list (object))
  292. (defgeneric quiet-zone (object))
  293. (defmethod parse ((object code128) codes)
  294. (with-accessors ((code code)
  295. (width width)) object
  296. (setf code (parse-code128 (tokenize-all codes)))
  297. (setf width (+ (* 2 (quiet-zone object))
  298. (barcode-width (bars-list object) (bar-width object))))))
  299. (defmethod bars-list ((object code128))
  300. (reduce #'append
  301. (mapcar #'(lambda (cd) (fourth (find-row cd)))
  302. (code object))))
  303. (defmethod quiet-zone ((object code128))
  304. (let ((rel (* +code128-min-quiet-zone-rel+ (bar-width object))))
  305. (if (< rel +code128-min-quiet-zone-abs+)
  306. +code128-min-quiet-zone-abs+
  307. rel)))
  308. (defmethod draw ((object code128) (doc cl-pslib:psdoc))
  309. (let ((all-bars (bars-list object)))
  310. (cl-pslib:save doc)
  311. (cl-pslib:setcolor doc cl-pslib:+color-type-fillstroke+ cl-colors2:+white+)
  312. (cl-pslib:rect doc 0 0 (quiet-zone object) (height object))
  313. (cl-pslib:fill-path doc)
  314. (cl-pslib:translate doc (quiet-zone object) 0)
  315. ;; ---
  316. (draw-bars doc all-bars (bar-width object) (height object))
  317. (cl-pslib:save doc)
  318. (cl-pslib:setcolor doc cl-pslib:+color-type-fillstroke+ cl-colors2:+white+)
  319. (cl-pslib:translate doc (- (width object) (* 2 (quiet-zone object))) 0)
  320. (cl-pslib:rect doc 0 0 (quiet-zone object) (height object))
  321. (cl-pslib:fill-path doc)
  322. (cl-pslib:restore doc)
  323. ;; ---
  324. (cl-pslib:restore doc)))