module Graphics.Barcode.Code128 ( BarcodeConfig(..)
, Err(CantEncode)
, barcodeSize
, barcodePDF
, drawBarcode) where
import Control.Applicative ((<$>), pure)
import Data.ByteString.Lazy (ByteString)
import Data.Char (isDigit, digitToInt)
import Data.Foldable (foldlM)
import Data.Maybe (listToMaybe)
import Graphics.PDF
data BarcodeConfig = BarcodeConfig
{ height :: Double
, barWidth :: Double
}
data Err = CantEncode Char
| InternalError String
deriving (Show)
barcodeSize :: BarcodeConfig -> [Char] -> Either Err (Double, Double)
barcodeSize config str = do encoded <- encode str
return (width (length encoded), height config)
where width i = quietZone +
codeWidth config * fromIntegral i +
quietZone
quietZone = codeWidth config
drawBarcode :: BarcodeConfig
-> String
-> Point
-> Either Err (Draw Point)
drawBarcode config str start@(_ :+ y) =
do codes <- encode str
return $ do (x' :+ _) <- quietZone start
(x'' :+ _) <- drawChars config codes (x' :+ y)
quietZone (x'' :+ y)
where quietWidth = codeWidth config
quietZone (x :+ y) = do fillColor white
setWidth 0
let corner2 = (( x + quietWidth) :+
(y + height config))
fill $ Rectangle (x :+ y)
corner2
return corner2
barcodePDF :: BarcodeConfig -> String -> IO ByteString
barcodePDF config str =
case barcodeSize config str of
Left err -> fail (show err)
Right (w, h) ->
pdfByteString standardDocInfo { compressed = False}
(PDFRect 0 0 (ceiling w) (ceiling h)) $ do
p <- addPage Nothing
drawWithPage p $ do
case drawBarcode config str (0 :+ 0) of
Left err -> fail (show err)
Right code -> code
data Code128Digit = One | Two | Three | Four
deriving (Eq, Ord, Show)
data Code128Code = Code128Code Code128Digit Code128Digit
Code128Digit Code128Digit
Code128Digit Code128Digit
| StopCode
deriving (Eq, Ord, Show)
data Code128Interp = CharValue Char
| FNC1
| FNC2
| FNC3
| FNC4
| CodeA
| CodeB
| CodeC
| ShiftA
| ShiftB
| Digits Int Int
| Stop
| StartA
| StartB
| StartC
deriving (Eq, Show)
data Code128Symbol = Code128Symbol
{ code :: Code128Code
, value :: Int
, codeA :: Code128Interp
, codeB :: Code128Interp
, codeC :: Code128Interp
}
deriving (Show, Eq)
code128SymbolTable :: [Code128Symbol]
code128SymbolTable =
[ Code128Symbol (Code128Code Two One Two Two Two Two) 0 (CharValue ' ') (CharValue ' ') (Digits 0 0)
, Code128Symbol (Code128Code Two Two Two One Two Two) 1 (CharValue '!') (CharValue '!') (Digits 0 1)
, Code128Symbol (Code128Code Two Two Two Two Two One) 2 (CharValue '"') (CharValue '"') (Digits 0 2)
, Code128Symbol (Code128Code One Two One Two Two Three) 3 (CharValue '#') (CharValue '#') (Digits 0 3)
, Code128Symbol (Code128Code One Two One Three Two Two) 4 (CharValue '$') (CharValue '$') (Digits 0 4)
, Code128Symbol (Code128Code One Three One Two Two Two) 5 (CharValue '%') (CharValue '%') (Digits 0 5)
, Code128Symbol (Code128Code One Two Two Two One Three) 6 (CharValue '&') (CharValue '&') (Digits 0 6)
, Code128Symbol (Code128Code One Two Two Three One Two) 7 (CharValue '\'') (CharValue '\'') (Digits 0 7)
, Code128Symbol (Code128Code One Three Two Two One Two) 8 (CharValue '(') (CharValue '(') (Digits 0 8)
, Code128Symbol (Code128Code Two Two One Two One Three) 9 (CharValue ')') (CharValue ')') (Digits 0 9)
, Code128Symbol (Code128Code Two Two One Three One Two) 10 (CharValue '*') (CharValue '*') (Digits 1 0)
, Code128Symbol (Code128Code Two Three One Two One Two) 11 (CharValue '+') (CharValue '+') (Digits 1 1)
, Code128Symbol (Code128Code One One Two Two Three Two) 12 (CharValue ',') (CharValue ',') (Digits 1 2)
, Code128Symbol (Code128Code One Two Two One Three Two) 13 (CharValue '-') (CharValue '-') (Digits 1 3)
, Code128Symbol (Code128Code One Two Two Two Three One) 14 (CharValue '.') (CharValue '.') (Digits 1 4)
, Code128Symbol (Code128Code One One Three Two Two Two) 15 (CharValue '/') (CharValue '/') (Digits 1 5)
, Code128Symbol (Code128Code One Two Three One Two Two) 16 (CharValue '0') (CharValue '0') (Digits 1 6)
, Code128Symbol (Code128Code One Two Three Two Two One) 17 (CharValue '1') (CharValue '1') (Digits 1 7)
, Code128Symbol (Code128Code Two Two Three Two One One) 18 (CharValue '2') (CharValue '2') (Digits 1 8)
, Code128Symbol (Code128Code Two Two One One Three Two) 19 (CharValue '3') (CharValue '3') (Digits 1 9)
, Code128Symbol (Code128Code Two Two One Two Three One) 20 (CharValue '4') (CharValue '4') (Digits 2 0)
, Code128Symbol (Code128Code Two One Three Two One Two) 21 (CharValue '5') (CharValue '5') (Digits 2 1)
, Code128Symbol (Code128Code Two Two Three One One Two) 22 (CharValue '6') (CharValue '6') (Digits 2 2)
, Code128Symbol (Code128Code Three One Two One Three One) 23 (CharValue '7') (CharValue '7') (Digits 2 3)
, Code128Symbol (Code128Code Three One One Two Two Two) 24 (CharValue '8') (CharValue '8') (Digits 2 4)
, Code128Symbol (Code128Code Three Two One One Two Two) 25 (CharValue '9') (CharValue '9') (Digits 2 5)
, Code128Symbol (Code128Code Three Two One Two Two One) 26 (CharValue ':') (CharValue ':') (Digits 2 6)
, Code128Symbol (Code128Code Three One Two Two One Two) 27 (CharValue ';') (CharValue ';') (Digits 2 7)
, Code128Symbol (Code128Code Three Two Two One One Two) 28 (CharValue '<') (CharValue '<') (Digits 2 8)
, Code128Symbol (Code128Code Three Two Two Two One One) 29 (CharValue '=') (CharValue '=') (Digits 2 9)
, Code128Symbol (Code128Code Two One Two One Two Three) 30 (CharValue '>') (CharValue '>') (Digits 3 0)
, Code128Symbol (Code128Code Two One Two Three Two One) 31 (CharValue '?') (CharValue '?') (Digits 3 1)
, Code128Symbol (Code128Code Two Three Two One Two One) 32 (CharValue '@') (CharValue '@') (Digits 3 2)
, Code128Symbol (Code128Code One One One Three Two Three) 33 (CharValue 'A') (CharValue 'A') (Digits 3 3)
, Code128Symbol (Code128Code One Three One One Two Three) 34 (CharValue 'B') (CharValue 'B') (Digits 3 4)
, Code128Symbol (Code128Code One Three One Three Two One) 35 (CharValue 'C') (CharValue 'C') (Digits 3 5)
, Code128Symbol (Code128Code One One Two Three One Three) 36 (CharValue 'D') (CharValue 'D') (Digits 3 6)
, Code128Symbol (Code128Code One Three Two One One Three) 37 (CharValue 'E') (CharValue 'E') (Digits 3 7)
, Code128Symbol (Code128Code One Three Two Three One One) 38 (CharValue 'F') (CharValue 'F') (Digits 3 8)
, Code128Symbol (Code128Code Two One One Three One Three) 39 (CharValue 'G') (CharValue 'G') (Digits 3 9)
, Code128Symbol (Code128Code Two Three One One One Three) 40 (CharValue 'H') (CharValue 'H') (Digits 4 0)
, Code128Symbol (Code128Code Two Three One Three One One) 41 (CharValue 'I') (CharValue 'I') (Digits 4 1)
, Code128Symbol (Code128Code One One Two One Three Three) 42 (CharValue 'J') (CharValue 'J') (Digits 4 2)
, Code128Symbol (Code128Code One One Two Three Three One) 43 (CharValue 'K') (CharValue 'K') (Digits 4 3)
, Code128Symbol (Code128Code One Three Two One Three One) 44 (CharValue 'L') (CharValue 'L') (Digits 4 4)
, Code128Symbol (Code128Code One One Three One Two Three) 45 (CharValue 'M') (CharValue 'M') (Digits 4 5)
, Code128Symbol (Code128Code One One Three Three Two One) 46 (CharValue 'N') (CharValue 'N') (Digits 4 6)
, Code128Symbol (Code128Code One Three Three One Two One) 47 (CharValue 'O') (CharValue 'O') (Digits 4 7)
, Code128Symbol (Code128Code Three One Three One Two One) 48 (CharValue 'P') (CharValue 'P') (Digits 4 8)
, Code128Symbol (Code128Code Two One One Three Three One) 49 (CharValue 'Q') (CharValue 'Q') (Digits 4 9)
, Code128Symbol (Code128Code Two Three One One Three One) 50 (CharValue 'R') (CharValue 'R') (Digits 5 0)
, Code128Symbol (Code128Code Two One Three One One Three) 51 (CharValue 'S') (CharValue 'S') (Digits 5 1)
, Code128Symbol (Code128Code Two One Three Three One One) 52 (CharValue 'T') (CharValue 'T') (Digits 5 2)
, Code128Symbol (Code128Code Two One Three One Three One) 53 (CharValue 'U') (CharValue 'U') (Digits 5 3)
, Code128Symbol (Code128Code Three One One One Two Three) 54 (CharValue 'V') (CharValue 'V') (Digits 5 4)
, Code128Symbol (Code128Code Three One One Three Two One) 55 (CharValue 'W') (CharValue 'W') (Digits 5 5)
, Code128Symbol (Code128Code Three Three One One Two One) 56 (CharValue 'X') (CharValue 'X') (Digits 5 6)
, Code128Symbol (Code128Code Three One Two One One Three) 57 (CharValue 'Y') (CharValue 'Y') (Digits 5 7)
, Code128Symbol (Code128Code Three One Two Three One One) 58 (CharValue 'Z') (CharValue 'Z') (Digits 5 8)
, Code128Symbol (Code128Code Three Three Two One One One) 59 (CharValue '[') (CharValue '[') (Digits 5 9)
, Code128Symbol (Code128Code Three One Four One One One) 60 (CharValue '\\') (CharValue '\\') (Digits 6 0)
, Code128Symbol (Code128Code Two Two One Four One One) 61 (CharValue ']') (CharValue ']') (Digits 6 1)
, Code128Symbol (Code128Code Four Three One One One One) 62 (CharValue '^') (CharValue '^') (Digits 6 2)
, Code128Symbol (Code128Code One One One Two Two Four) 63 (CharValue '_') (CharValue '_') (Digits 6 3)
, Code128Symbol (Code128Code One One One Four Two Two) 64 (CharValue '\NUL') (CharValue '`') (Digits 6 4)
, Code128Symbol (Code128Code One Two One One Two Four) 65 (CharValue '\SOH') (CharValue 'a') (Digits 6 5)
, Code128Symbol (Code128Code One Two One Four Two One) 66 (CharValue '\STX') (CharValue 'b') (Digits 6 6)
, Code128Symbol (Code128Code One Four One One Two Two) 67 (CharValue '\ETX') (CharValue 'c') (Digits 6 7)
, Code128Symbol (Code128Code One Four One Two Two One) 68 (CharValue '\EOT') (CharValue 'd') (Digits 6 8)
, Code128Symbol (Code128Code One One Two Two One Four) 69 (CharValue '\ENQ') (CharValue 'e') (Digits 6 9)
, Code128Symbol (Code128Code One One Two Four One Two) 70 (CharValue '\ACK') (CharValue 'f') (Digits 7 0)
, Code128Symbol (Code128Code One Two Two One One Four) 71 (CharValue '\BEL') (CharValue 'g') (Digits 7 1)
, Code128Symbol (Code128Code One Two Two Four One One) 72 (CharValue '\BS') (CharValue 'h') (Digits 7 2)
, Code128Symbol (Code128Code One Four Two One One Two) 73 (CharValue '\HT') (CharValue 'i') (Digits 7 3)
, Code128Symbol (Code128Code One Four Two Two One One) 74 (CharValue '\LF') (CharValue 'j') (Digits 7 4)
, Code128Symbol (Code128Code Two Four One Two One One) 75 (CharValue '\VT') (CharValue 'k') (Digits 7 5)
, Code128Symbol (Code128Code Two Two One One One Four) 76 (CharValue '\FF') (CharValue 'l') (Digits 7 6)
, Code128Symbol (Code128Code Four One Three One One One) 77 (CharValue '\CR') (CharValue 'm') (Digits 7 7)
, Code128Symbol (Code128Code Two Four One One One Two) 78 (CharValue '\SO') (CharValue 'n') (Digits 7 8)
, Code128Symbol (Code128Code One Three Four One One One) 79 (CharValue '\SI') (CharValue 'o') (Digits 7 9)
, Code128Symbol (Code128Code One One One Two Four Two) 80 (CharValue '\DLE') (CharValue 'p') (Digits 8 0)
, Code128Symbol (Code128Code One Two One One Four Two) 81 (CharValue '\DC1') (CharValue 'q') (Digits 8 1)
, Code128Symbol (Code128Code One Two One Two Four One) 82 (CharValue '\DC2') (CharValue 'r') (Digits 8 2)
, Code128Symbol (Code128Code One One Four Two One Two) 83 (CharValue '\DC3') (CharValue 's') (Digits 8 3)
, Code128Symbol (Code128Code One Two Four One One Two) 84 (CharValue '\DC4') (CharValue 't') (Digits 8 4)
, Code128Symbol (Code128Code One Two Four Two One One) 85 (CharValue '\NAK') (CharValue 'u') (Digits 8 5)
, Code128Symbol (Code128Code Four One One Two One Two) 86 (CharValue '\SYN') (CharValue 'v') (Digits 8 6)
, Code128Symbol (Code128Code Four Two One One One Two) 87 (CharValue '\ETB') (CharValue 'w') (Digits 8 7)
, Code128Symbol (Code128Code Four Two One Two One One) 88 (CharValue '\CAN') (CharValue 'x') (Digits 8 8)
, Code128Symbol (Code128Code Two One Two One Four One) 89 (CharValue '\EM') (CharValue 'y') (Digits 8 9)
, Code128Symbol (Code128Code Two One Four One Two One) 90 (CharValue '\SUB') (CharValue 'z') (Digits 9 0)
, Code128Symbol (Code128Code Four One Two One Two One) 91 (CharValue '\ESC') (CharValue '{') (Digits 9 1)
, Code128Symbol (Code128Code One One One One Four Three) 92 (CharValue '\FS') (CharValue '|') (Digits 9 2)
, Code128Symbol (Code128Code One One One Three Four One) 93 (CharValue '\GS') (CharValue '}') (Digits 9 3)
, Code128Symbol (Code128Code One Three One One Four One) 94 (CharValue '\RS') (CharValue '~') (Digits 9 4)
, Code128Symbol (Code128Code One One Four One One Three) 95 (CharValue '\US') (CharValue '\DEL') (Digits 9 5)
, Code128Symbol (Code128Code One One Four Three One One) 96 FNC3 FNC3 (Digits 9 6)
, Code128Symbol (Code128Code Four One One One One Three) 97 FNC2 FNC2 (Digits 9 7)
, Code128Symbol (Code128Code Four One One Three One One) 98 ShiftB ShiftA (Digits 9 8)
, Code128Symbol toC 99 CodeC CodeC (Digits 9 9)
, Code128Symbol toB 100 CodeB FNC4 CodeB
, Code128Symbol toA 101 FNC4 CodeA CodeA
, Code128Symbol (Code128Code Four One One One Three One) 102 FNC1 FNC1 FNC1
, Code128Symbol startA 103 StartA StartA StartA
, Code128Symbol startB 104 StartB StartB StartB
, Code128Symbol startC 105 StartC StartC StartC
]
startA, startB, startC :: Code128Code
startA = Code128Code Two One One Four One Two
startB = Code128Code Two One One Two One Four
startC = Code128Code Two One One Two Three Two
toA, toB, toC :: Code128Code
toA = Code128Code Three One One One Four One
toB = Code128Code One One Four One Three One
toC = Code128Code One One Three One Four One
toBars :: Code128Code -> [Code128Digit]
toBars (Code128Code x1 x2 x3 x4 x5 x6) = [x1, x2, x3, x4, x5, x6]
toBars StopCode = [Two, Three, Three, One, One, One, Two]
digitWidth :: Code128Digit -> Int
digitWidth One = 1
digitWidth Two = 2
digitWidth Three = 3
digitWidth Four = 4
codeWidth :: BarcodeConfig -> Double
codeWidth config = barWidth config * 11
bool :: a -> a -> Bool -> a
bool x _ False = x
bool _ y True = y
symbolForCode :: Code128Code -> Either Err Code128Symbol
symbolForCode c = getSym code128SymbolTable
where getSym [] = Left . InternalError $ "No symbol for " ++ show c
getSym (sym:table) | c == code sym = Right sym
| otherwise = getSym table
symbolForValue :: Int -> Either Err Code128Symbol
symbolForValue i = getSym code128SymbolTable
where getSym [] = Left . InternalError $ "No symbol with value " ++ show i
getSym (sym:table) | i == value sym = Right sym
| otherwise = getSym table
checksum :: [Code128Code] -> Either Err Code128Code
checksum str = do syms <- mapM symbolForCode str
let total = sum $ zipWith (*) (map value syms) (1:[1..])
check = total `mod` 103
checkSym <- symbolForValue check
return (code checkSym)
inA :: Char -> Maybe Code128Code
inA c = code <$> (listToMaybe . filter ((CharValue c ==) . codeA)) code128SymbolTable
inB :: Char -> Maybe Code128Code
inB c = code <$> (listToMaybe . filter ((CharValue c ==) . codeB)) code128SymbolTable
inC :: Char -> Char -> Maybe Code128Code
inC d1 d2 | isDigit d1, isDigit d2 = getC (Digits (digitToInt d1) (digitToInt d2)) code128SymbolTable
| otherwise = Nothing
where getC i table = code <$> (listToMaybe . filter ((i==) . codeC)) table
data EncoderState = None | StateA | StateB | StateC
encode' :: EncoderState -> [Char] -> Either Err [Code128Code]
encode' _ [] = pure []
encode' None (w:x:y:z:rest) | Just c1 <- inC w x
, Just c2 <- inC y z = ([startC, c1, c2] ++ ) <$> encode' StateC rest
encode' None (x:xs) | Just b <- inB x = ([startB, b] ++) <$> encode' StateB xs
| Just a <- inA x = ([startA, a] ++) <$> encode' StateA xs
| otherwise = Left (CantEncode x)
encode' StateA (u:v:w:x:y:z:rest) | Just c1 <- inC u v
, Just c2 <- inC w x
, Just c3 <- inC y z
= ([toC, c1, c2, c3] ++) <$> encode' StateC rest
encode' StateA [w,x,y,z] | Just c1 <- inC w x
, Just c2 <- inC y z = pure [toC, c1, c2]
encode' StateA (x:rest) | Just a <- inA x = (a :) <$> encode' StateA rest
| Just b <- inB x = ([toB, b] ++) <$> encode' StateB rest
| otherwise = error "invalid input string"
encode' StateB (u:v:w:x:y:z:rest) | Just c1 <- inC u v
, Just c2 <- inC w x
, Just c3 <- inC y z
= ([toC, c1, c2, c3] ++) <$> encode' StateC rest
encode' StateB [w,x,y,z] | Just c1 <- inC w x
, Just c2 <- inC y z = pure [toC, c1, c2]
encode' StateB (x:rest) | Just b <- inB x = (b :) <$> encode' StateB rest
| Just a <- inA x = ([toA, a] ++) <$> encode' StateA rest
| otherwise = Left (CantEncode x)
encode' StateC [x] | Just b <- inB x = pure [toB, b]
| Just a <- inA x = pure [toA, a]
| otherwise = Left (CantEncode x)
encode' StateC (x:y:rest) | Just c <- inC x y = (c :) <$> encode' StateC rest
| Just b <- inB x = ([toB, b] ++) <$> encode' StateB (y:rest)
| Just a <- inA x = ([toA, a] ++) <$> encode' StateA (y:rest)
| otherwise = Left (CantEncode x)
checksummed :: [Code128Code] -> Either Err [Code128Code]
checksummed xs = do cs <- checksum xs
return $ xs ++ [cs, StopCode]
encode :: [Char] -> Either Err [Code128Code]
encode str = encode' None str >>= checksummed
drawChar :: BarcodeConfig -> Point -> Code128Code -> Draw Point
drawChar config at c = snd <$> foldlM drawBar (False, at) (toBars c)
where drawBar (color, topLeft@(left :+ top)) bar = do
strokeColor $ bool black white color
fillColor $ bool black white color
setWidth 0
let left' = left + fromIntegral (digitWidth bar) * barWidth config
fill . Rectangle topLeft $
(left' :+ (top + height config))
return $ (not color, (left' :+ top))
drawChars :: BarcodeConfig -> [Code128Code] -> Point -> Draw Point
drawChars config codes start = foldlM (drawChar config) start codes
test :: String -> IO ()
test str = do let config = BarcodeConfig 40 1
Right (w, h) = barcodeSize config str
rect = PDFRect 0 0 (ceiling w + 20) (ceiling h + 20)
runPdf "demo.pdf" standardDocInfo { compressed = False } rect $ do
p <- addPage Nothing
drawWithPage p $ do
fillColor red
setWidth 0
fill $ Rectangle (0 :+ 0) (600 :+ 100)
case drawBarcode (BarcodeConfig 40 1) str (10 :+ 10) of
Left err -> error (show err)
Right code -> code