Barcode generator for EAN-8/13 and UPC-A

barcode.red

Red [
	Title:		"Barcode generator"
	Purpose:	{To generate and display EAN-8 and -13, as well as UPC-A barcodes}
	Author:		"Rudolf W. MEIJER"
	File:		%barcode.red
	Version:	0.1.0
	Date:		1-Oct-2017
	Rights:		"Copyright (c) Rudolf W. MEIJER"
	Needs:		'View
	History:	[
					0.0.0 30-Sep-2017 {Start of project}
					0.1.0  1-Oct-2017 {First working version}
				]
	Notes:		{see https://en.wikipedia.org/wiki/International_Article_Number}
	Language:	'English
	Tabs:		4
]

;---|----1----|----2----|----3----|----4----|----5----|----6----|----7----|-

check-digit: func [
	{compute check digit for EAN-8 and -13 codes}
	code [string!]	"7 or 12 digits"
	/local lg wt tot rst
][
	lg: length? code
	tot: 0
	wt: 3
	while [lg > 0][
		tot: (to-integer code/:lg - #"0") * wt + tot
		lg: lg - 1
		wt: 4 - wt
	]
	rst: tot % 10
	return #"0"+ either rst = 0 [0][10 - rst]
]

verify-digit: func [
	{verify check digit for EAN-8 and -13 codes}
	code [string!]	"8 or 13 digits"
	/local lg
][
	lg: length? code
	(last code) = check-digit copy/part code lg - 1
]

clean-up: func [
	{remove spaces and other non-digits from input}
	text [string!]	"input to be cleaned up"
	/local dg code
][
	code: copy text
	remove-each dg code [any [dg < #"0" dg > #"9"]]
	code
]

draw-ean: func [
	{produce draw instructions for bars}
	/local code bars nb lw lm lb db x i
][
	code: clean-up ean/text				; remove spaces etc.
	unless find [7 8 11 12 13] length? code [return none]
	bars: encode-ean code				; produce 56 or 84 0/1's
	
	unless bars [return none]
	
	; determine width of one line (line-width)
	nb: length? bars					; number of bits
	lw: barc/size/x / (11 + nb)			; includes start, center and end markers

	; determine length of start, center and end marker lines
	; and of other lines (bars)
	lm: barc/size/y
	lb: to-integer lm * 85%

	; initialize draw block
	db: compose [pen black line-width (lw)]
	x: (barc/size/x - (11 + nb * lw)) / 2

	; draw start marker ("101")
	append db compose [line (as-pair x 0) (as-pair x lm)]
	x: x + (2 * lw)
	append db compose [line (as-pair x 0) (as-pair x lm)]

	; draw first half of bars
	repeat i nb / 2 [
		x: x + lw
		if #"1" = bars/:i [
			append db compose [line (as-pair x 0) (as-pair x lb)]
		]
	]

	; draw center marker ("01010")
	x: x + (2 * lw)
	append db compose [line (as-pair x 0) (as-pair x lm)]
	x: x + (2 * lw)
	append db compose [line (as-pair x 0) (as-pair x lm)]
	x: x + lw

	; draw second half of bars
	repeat i nb / 2 [
		x: x + lw
		if #"1" = bars/(nb / 2 + i) [
			append db compose [line (as-pair x 0) (as-pair x lb)]
		]
	]

	; draw end marker
	x: x + lw
	append db compose [line (as-pair x 0) (as-pair x lm)]
	x: x + (2 * lw)
	append db compose [line (as-pair x 0) (as-pair x lm)]

	; return draw block
	db
]

encode-ean: func [
	{wrapper for encode-ean-8 and encode-ean-13}
	code [string!]	"7 8 11 12 or 13 digits"
	/local lg cd
][
	cd: copy code
	lg: length? cd
	switch lg [
		 7 [							; EAN-8 w/o check-digit
			append cd check-digit cd
			encode-ean-8 cd
		]
		 8 [							; EAN-8 with check-digit
			all [
				verify-digit cd
				encode-ean-8 cd
			]
		]
		11 [							; UPC-A w/o check-digit
			append cd check-digit cd
			insert cd #"0"
			encode-ean-13 cd
		]
		12 [							; EAN-13 w/o check-digit
			append cd check-digit cd
			encode-ean-13 cd
		]
		13 [							; EAN-13 with check-digit
			all [
				verify-digit cd
				encode-ean-13 cd
			]
		]
	]
]

encode-ean-8: func [
	{produce string of characters 0 and 1 representing bars, w/o start, end
	and center marker, using ean-8 algorithm}
	code [string!]	"8 digits"
	/local i dg nr pt res
][
	res: copy ""
	repeat i 8 [
		dg: code/:i							; digit
		pt: ean-8-enc/:i					; encoding L or R
		append res digit-enc/:dg/:pt		; lookup bits
	]
]

encode-ean-13: func [
	{produce string of characters 0 and 1 representing bars, w/o start, end
	and center marker, using ean-13 algorithm}
	code [string!]	"13 digits"
	/local fd i dg nr ptn pt cd res
][
	res: copy ""
	fd: first code							; first digit
	ptn: ean-13-enc/:fd						; lookup pattern of L G R
	cd: next code							; use only 12 digits
	repeat i 12 [
		dg: cd/:i							; digit
		pt: ptn/:i							; encoding L G or R
		append res digit-enc/:dg/:pt		; lookup bits
	]
]

ean-13-enc: #(
	#"0" "LLLLLLRRRRRR"
	#"1" "LLGLGGRRRRRR"
	#"2" "LLGGLGRRRRRR"
	#"3" "LLGGGLRRRRRR"
	#"4" "LGLLGGRRRRRR"
	#"5" "LGGLLGRRRRRR"
	#"6" "LGGGLLRRRRRR"
	#"7" "LGLGLGRRRRRR"
	#"8" "LGLGGLRRRRRR"
	#"9" "LGGLGLRRRRRR"
)

ean-8-enc: "LLLLRRRR"

digit-enc: #(
	#"0"	#( #"L" "0001101" #"G" "0100111" #"R" "1110010" )
	#"1"	#( #"L" "0011001" #"G" "0110011" #"R" "1100110" )
	#"2"	#( #"L" "0010011" #"G" "0011011" #"R" "1101100" )
	#"3"	#( #"L" "0111101" #"G" "0100001" #"R" "1000010" )
	#"4"	#( #"L" "0100011" #"G" "0011101" #"R" "1011100" )
	#"5"	#( #"L" "0110001" #"G" "0111001" #"R" "1001110" )
	#"6"	#( #"L" "0101111" #"G" "0000101" #"R" "1010000" )
	#"7"	#( #"L" "0111011" #"G" "0010001" #"R" "1000100" )
	#"8"	#( #"L" "0110111" #"G" "0001001" #"R" "1001000" )
	#"9"	#( #"L" "0001011" #"G" "0010111" #"R" "1110100" )
)


view [
	pad 0x20 return
	barc: base white 210x100 return
	pad 0x20 return
	text 40 "EAN" bold 
	ean: field 90 ""
	button "Show" [barc/draw: draw-ean] return
	pad 150x0 button "Quit" [quit]
]