diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2014 David Raymond Christiansen, Galois, Inc. + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/barcodes-code128.cabal b/barcodes-code128.cabal new file mode 100644 --- /dev/null +++ b/barcodes-code128.cabal @@ -0,0 +1,35 @@ +name: barcodes-code128 +version: 0.1.0 +synopsis: Generate Code 128 barcodes as PDFs +description: + A library for generating barcodes in Code 128 in PDF format, either + directly as 'Data.ByteString.Lazy.ByteString's or as drawing commands + in 'HPDF''s command set. + + Code 128 is described at . +license: MIT +license-file: LICENSE +author: David Raymond Christiansen +maintainer: david@davidchristiansen.dk +copyright: (c) 2014 David Raymond Christiansen, Galois, Inc. +category: Graphics +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 +stability: provisional +homepage: +bug-reports: https://github.com/david-christiansen/barcodes-code128/issues + +source-repository head + type: git + location: git://github.com/david-christiansen/barcodes-code128.git + +library + exposed-modules: Graphics.Barcode.Code128 + -- other-modules: + -- other-extensions: + build-depends: base >=4.7 && <4.8, + bytestring >=0.10.4 && <0.11, + HPDF >=1.4.6 && <1.5 + hs-source-dirs: src + default-language: Haskell2010 diff --git a/src/Graphics/Barcode/Code128.hs b/src/Graphics/Barcode/Code128.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Barcode/Code128.hs @@ -0,0 +1,397 @@ +-- | A library for generating barcodes in Code 128. Details of the +-- encoding are available at . +-- The width of the stripes and the height of the barcode are +-- configurable. Two modes of operation are supported: +-- +-- * Constructing a PDF directly in a 'ByteString', and +-- * Constructing an action in 'HPDF''s 'Draw' monad, for composing +-- the barcode with other information in a PDF. +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 + +------------------- +-- Public interface +------------------- + +-- | Controls the size of the generated barcode. All units are in +-- HPDF's internal sizing. +data BarcodeConfig = BarcodeConfig + { height :: Double -- ^ The height of the generated barcode + , barWidth :: Double -- ^ The width of the narrowest possible bar + } + +-- | Errors that can occur while constructing a barcode +data Err = CantEncode Char -- ^ The returned character cannot be encoded in Code 128 + | InternalError String -- ^ An internal error occurred, indicating a bug in the library + deriving (Show) + + +-- | Determine the width and height of rendering a particular string +-- as a barcode in a particular configuration. +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 -- minimum according to standard + +-- | Encode a string and construct an action in 'Draw' that will +-- render it as a barcode. The action, if created successfully, will +-- return the opposite corner of the barcode. An error is returned if the string +-- could not be encoded as a Code128 barcode. +drawBarcode :: BarcodeConfig -- ^ How to render the barcode + -> String -- ^ The string to encode + -> Point -- ^ The origin (lower left) of the barcode on the page + -> 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 + +-- | Generate PDF data containing the barcode for a given string, with +-- the tightest possible bounding box. If the string cannot be encoded +-- in Code 128, an IOError is thrown. +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 + + +----------------- +-- Implementation +----------------- + +-- | Barcode stripes come in four widths +data Code128Digit = One | Two | Three | Four + deriving (Eq, Ord, Show) + +-- | A single code in the scheme consists of six stripes, or the +-- special seven-stripe stop code +data Code128Code = Code128Code Code128Digit Code128Digit + Code128Digit Code128Digit + Code128Digit Code128Digit + | StopCode + deriving (Eq, Ord, Show) + + +-- | The raw codes have a number of potential semantic +-- interpretations, depending on their position in the code +data Code128Interp = CharValue Char + | FNC1 + | FNC2 + | FNC3 + | FNC4 + | CodeA + | CodeB + | CodeC + | ShiftA + | ShiftB + | Digits Int Int -- ^ Each Int between 0 and 9 inclusive + | Stop + | StartA + | StartB + | StartC + deriving (Eq, Show) + +-- | A particular symbol has three potential interpretations, +-- depending on the present coding scheme, and a value for +-- checksumming +data Code128Symbol = Code128Symbol + { code :: Code128Code + , value :: Int + , codeA :: Code128Interp + , codeB :: Code128Interp + , codeC :: Code128Interp + } + deriving (Show, Eq) + +-- | The Code 128 symbol table +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 + ] + +-- | The three start codes determine the initial scheme +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 + +-- | The coding change characters are valid only in the other schemes +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 + +-- | Interpret a code as a list of digits +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) + +-- | Whether a character can be encoded in code set A +inA :: Char -> Maybe Code128Code +inA c = code <$> (listToMaybe . filter ((CharValue c ==) . codeA)) code128SymbolTable + + +-- | Whether a character can be encoded in code set B +inB :: Char -> Maybe Code128Code +inB c = code <$> (listToMaybe . filter ((CharValue c ==) . codeB)) code128SymbolTable + +-- | Whether a pair of characters can be encoded in code set C +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 [] +-- It's worth encoding in code C at the beginning if there's at least four digits at the start +encode' None (w:x:y:z:rest) | Just c1 <- inC w x + , Just c2 <- inC y z = ([startC, c1, c2] ++ ) <$> encode' StateC rest +-- Otherwise prefer code B because lowercase letters are more likely than control codes +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) + +-- In state A, switch to C if there's a run of at least 6 digits in the middle +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 +-- Also switch to C if there's precisely 4 digits remaining +encode' StateA [w,x,y,z] | Just c1 <- inC w x + , Just c2 <- inC y z = pure [toC, c1, c2] +-- Otherwise attempt to stay in A, but switch to B if necessary +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" -- todo error monad + +-- In state B, switch to C if there's a run of at least 6 digits in the middle +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 +-- Also switch to C if there's precisely 4 digits remaining +encode' StateB [w,x,y,z] | Just c1 <- inC w x + , Just c2 <- inC y z = pure [toC, c1, c2] +-- Otherwise attempt to stay in B, but switch to A if necessary +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) + +-- TODO: We should really prevent this, by only switching to C if the prefix of digits is even-length +encode' StateC [x] | Just b <- inB x = pure [toB, b] + | Just a <- inA x = pure [toA, a] + | otherwise = Left (CantEncode x) +-- If in state C, attempt to stay there, otherwise prefer B over A +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 + +-- Simple test, for use when developing the library +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