├── .gitignore ├── Setup.hs ├── doc └── hello.png ├── TODO ├── Example.hs ├── Codec └── Binary │ ├── QRCode │ ├── VersionInfo.hs │ ├── FormatInfo.hs │ ├── Modes │ │ ├── EightBit.hs │ │ ├── Numeric.hs │ │ └── Alphanumeric.hs │ ├── Utils.hs │ ├── Matrix.hs │ ├── Blocks.hs │ ├── Masks.hs │ ├── GaloisField.hs │ ├── Placement.hs │ └── Spec.hs │ └── QRCode.hs ├── README.markdown ├── LICENSE ├── qrcode.cabal ├── stack.yaml └── test └── test.hs /.gitignore: -------------------------------------------------------------------------------- 1 | /dist/ 2 | /.stack-work/ 3 | /hello.pgm 4 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /doc/hello.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/kizzx2/haskell-qrcode/HEAD/doc/hello.png -------------------------------------------------------------------------------- /TODO: -------------------------------------------------------------------------------- 1 | - ECI modes 2 | - Strctured append 3 | - Decoding 4 | - Automatic mode selection algorithm 5 | - Improve performance (use ByteString (or BitStream)) 6 | -------------------------------------------------------------------------------- /Example.hs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env stack 2 | -- stack exec --package pgm runghc 3 | 4 | import Graphics.Pgm 5 | import Data.Maybe 6 | 7 | import Codec.Binary.QRCode 8 | 9 | main :: IO () 10 | main = arrayToFile "hello.pgm" 11 | . toArray 12 | . fromJust 13 | . encode (fromJust $ version 1) M Alphanumeric 14 | $ "hello world" 15 | -------------------------------------------------------------------------------- /Codec/Binary/QRCode/VersionInfo.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK hide #-} 2 | module Codec.Binary.QRCode.VersionInfo where 3 | 4 | import Codec.Binary.QRCode.Spec 5 | import Codec.Binary.QRCode.Utils 6 | 7 | import Codec.Binary.QRCode.GaloisField 8 | 9 | encode :: Version -> BitStream 10 | encode (Version v) = showBinPadded 18 encoded 11 | where 12 | inputPoly = gfpRightPad 12 $ toPoly (showBinPadded 6 v) 13 | encoded = gfpToBinaryRepr $ gfpAdd inputPoly (snd $ gfpQuotRem inputPoly qrVersionInfoGenPoly) 14 | -------------------------------------------------------------------------------- /README.markdown: -------------------------------------------------------------------------------- 1 | # Basic Encoding 2 | 3 | The `encode` function and the `toArray` function are all you need. See `Example.hs`. You can use ImageMagick/GraphicsMagick to enlarge the symbol and convert to other formats: 4 | 5 | $ runhaskell Example.hs 6 | 7 | $ # ImageMagick 8 | $ convert hello.pgm -bordercolor white -border 4 -scale 300x300 -interpolate integer hello.png 9 | 10 | $ # GraphicsMagick 11 | $ gm convert hello.pgm -bordercolor white -border 4 -scale 300x300 hello.png 12 | 13 | Output: 14 | 15 | ![Example output](/doc/hello.png) 16 | -------------------------------------------------------------------------------- /Codec/Binary/QRCode/FormatInfo.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK hide #-} 2 | 3 | module Codec.Binary.QRCode.FormatInfo where 4 | 5 | import Codec.Binary.QRCode.Spec 6 | import Codec.Binary.QRCode.Utils 7 | 8 | import Codec.Binary.QRCode.GaloisField 9 | 10 | import Data.Bits 11 | 12 | encode :: ErrorLevel -> BitStream -> BitStream 13 | encode ec maskPatRef = showBinPadded 15 $ encoded `xor` qrFormatInfoMask 14 | where 15 | ecIndicator = qrErrorLevelIndicators ec 16 | input = ecIndicator ++ maskPatRef 17 | inputPoly = gfpRightPad 10 $ toPoly input 18 | encoded = gfpToBinaryRepr $ gfpAdd inputPoly (snd $ gfpQuotRem inputPoly qrFormatInfoGenPoly) 19 | -------------------------------------------------------------------------------- /Codec/Binary/QRCode/Modes/EightBit.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK hide #-} 2 | module Codec.Binary.QRCode.Modes.EightBit where 3 | 4 | import Codec.Binary.QRCode.Utils 5 | import Codec.Binary.QRCode.Spec 6 | 7 | import Data.Char 8 | 9 | convert :: Char -> Maybe Int 10 | convert c 11 | | isLatin1 c = Just $ ord c 12 | | otherwise = Nothing 13 | 14 | toCharValues :: Input -> Maybe [Int] 15 | toCharValues = mapM convert 16 | 17 | encode :: Version -> Input -> Maybe BitStream 18 | encode ver input = ((modeIndicatorBits ++ characterCountBits) ++) `fmap` dataBits 19 | where 20 | charValues = toCharValues input 21 | dataBits = concatMap (showBinPadded 8) `fmap` charValues 22 | 23 | modeIndicatorBits = "0100" 24 | characterCountBits = showBinPadded cciLength $ length input 25 | cciLength = qrLengthOfCCI ver EightBit 26 | -------------------------------------------------------------------------------- /Codec/Binary/QRCode/Modes/Numeric.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK hide #-} 2 | module Codec.Binary.QRCode.Modes.Numeric where 3 | 4 | import Numeric 5 | import Codec.Binary.QRCode.Utils 6 | import Codec.Binary.QRCode.Spec 7 | 8 | safeRead :: (Eq a, Num a) => String -> Maybe a 9 | safeRead x = case readDec x of 10 | [] -> Nothing 11 | ((x',_):_) -> Just x' 12 | 13 | convert :: Input -> Maybe String 14 | convert chunk = showBin `fmap` safeRead chunk 15 | where 16 | showBin = case length chunk of 17 | 3 -> showBinPadded 10 18 | 2 -> showBinPadded 7 19 | 1 -> showBinPadded 4 20 | _ -> error "Invalid chunk size" 21 | 22 | encode :: Version -> Input -> Maybe BitStream 23 | encode ver input = ((modeIndicatorBits ++ characterCountBits) ++) `fmap` dataBits 24 | where 25 | dataBits = concat `fmap` mapM convert (chunksOf 3 input) 26 | modeIndicatorBits = "0001" 27 | characterCountBits = showBinPadded cciLength $ length input 28 | cciLength = qrLengthOfCCI ver Numeric 29 | -------------------------------------------------------------------------------- /Codec/Binary/QRCode/Modes/Alphanumeric.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK hide #-} 2 | module Codec.Binary.QRCode.Modes.Alphanumeric where 3 | 4 | import Codec.Binary.QRCode.Utils 5 | import Codec.Binary.QRCode.Spec 6 | 7 | import Data.Char 8 | 9 | chars :: String 10 | chars = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ $%*+-./:" 11 | 12 | table :: [(Char, Int)] 13 | table = zip chars [0..44] 14 | 15 | convert :: Char -> Maybe Int 16 | convert = flip lookup table 17 | 18 | toCharValues :: Input -> Maybe [Int] 19 | toCharValues = mapM convert 20 | 21 | encode :: Version -> Input -> Maybe BitStream 22 | encode ver input = ((modeIndicatorBits ++ characterCountBits) ++) `fmap` dataBits 23 | where 24 | input' = map toUpper input 25 | charValues = toCharValues input' 26 | dataBits = (concatMap convertGroup . chunksOf 2) `fmap` charValues 27 | 28 | convertGroup [x] = showBinPadded 6 x 29 | convertGroup [x,y] = showBinPadded 11 $ x * 45 + y 30 | convertGroup _ = error "Impossible chunk size" 31 | 32 | modeIndicatorBits = "0010" 33 | characterCountBits = showBinPadded cciLength $ length input 34 | cciLength = qrLengthOfCCI ver Alphanumeric 35 | -------------------------------------------------------------------------------- /Codec/Binary/QRCode/Utils.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK hide #-} 2 | module Codec.Binary.QRCode.Utils where 3 | 4 | import Numeric 5 | import Data.Char 6 | 7 | import Codec.Binary.QRCode.Spec 8 | import Codec.Binary.QRCode.GaloisField 9 | 10 | import Control.Monad.Reader 11 | 12 | type Input = String 13 | type BitStream = String 14 | 15 | type ReaderQR = Reader Version 16 | 17 | -- | The smallest unit in a QR Code symbol (i.e. one "square"). 18 | data Module = Dark | Light deriving (Eq) 19 | 20 | type Modules = [Module] 21 | 22 | instance Bounded Module where 23 | maxBound = Light 24 | minBound = Dark 25 | 26 | instance Show Module where 27 | show Dark = "*" 28 | show Light = " " 29 | 30 | qrXor :: Module -> Module -> Module 31 | qrXor Dark Dark = Light 32 | qrXor Light Light = Light 33 | qrXor Dark Light = Dark 34 | qrXor Light Dark = Dark 35 | 36 | toModules :: BitStream -> Modules 37 | toModules = map conv 38 | where conv '1' = Dark 39 | conv '0' = Light 40 | conv x = error $ "Invalid BitStream element " ++ show x 41 | 42 | showBinPadded :: Int -> Int -> String 43 | showBinPadded len n = replicate (len - length str) '0' ++ str 44 | where 45 | str = showIntAtBase 2 intToDigit n "" 46 | 47 | chunksOf :: Int -> [a] -> [[a]] 48 | chunksOf n xs = go xs (length xs) [] 49 | where go xs' remLen acc | remLen <= n = reverse (xs' : acc) 50 | | otherwise = go (drop n xs') (remLen - n) (take n xs' : acc) 51 | 52 | toPoly :: BitStream -> GFPolynomial 53 | toPoly = mkPolynomial . map digitToInt 54 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c)2011, Chris Yuen 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Chris Yuen nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /Codec/Binary/QRCode/Matrix.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK hide #-} 2 | module Codec.Binary.QRCode.Matrix where 3 | 4 | import Data.Array.IArray 5 | import Codec.Binary.QRCode.Utils 6 | 7 | -- | Represents a QR Code symbol. 8 | newtype Matrix = QRM { getModules :: Array (Int,Int) Module } 9 | 10 | instance Show Matrix where 11 | show = showMatrix 12 | 13 | getWidth :: Array (Int, Int) Module -> Int 14 | getWidth = fst . snd . bounds 15 | 16 | -- | Convert a 'Matrix' to an array of 'Bounded' 17 | -- 'Light' modules will have the value 'maxBound'; 18 | -- 'Dark' modules will have the value 'minBound' 19 | toArray :: Bounded a => Matrix -> Array (Int, Int) a 20 | toArray (QRM m) = amap conv . ixmap bs inv $ m 21 | where 22 | conv Dark = minBound 23 | conv Light = maxBound 24 | 25 | bs = bounds m 26 | width = getWidth m 27 | inv (r,c) = (width - r, width - c) 28 | 29 | qrmCol :: Int -> Matrix -> Modules 30 | qrmCol n (QRM mat) = [mat ! (r,n) | r <- [0..(getWidth mat)]] 31 | 32 | qrmRow :: Int -> Matrix -> Modules 33 | qrmRow n (QRM mat) = [mat ! (n,c) | c <- [0..(getWidth mat)]] 34 | 35 | qrmWidth :: Matrix -> Int 36 | qrmWidth = getWidth . getModules 37 | 38 | qrmOverlay :: Matrix -> [((Int, Int), Module)] -> Matrix 39 | qrmOverlay (QRM mat) associations = QRM $ mat // associations 40 | 41 | show2DArray :: (Enum i, Num i, Ix i, Show e) => Array (i,i) e -> String 42 | show2DArray mods = rows 43 | where 44 | bound = fst . snd . bounds $ mods 45 | showFs = amap shows mods 46 | row r = foldr (.) ("\n"++) [showFs ! (r,col) | col <- reverse [0..bound]] 47 | rows = foldr (.) id [row r | r <- reverse [0..bound]] "" 48 | 49 | -- Show Matrix "top-down" 50 | -- i.e. (0,0) is displayed in bottom right 51 | showMatrix :: Matrix -> String 52 | showMatrix = show2DArray . getModules 53 | -------------------------------------------------------------------------------- /qrcode.cabal: -------------------------------------------------------------------------------- 1 | name: qrcode 2 | version: 0.1.4 3 | synopsis: QR Code library in pure Haskell 4 | license: BSD3 5 | license-file: LICENSE 6 | author: Chris Yuen 7 | maintainer: chris@kizzx2.com 8 | category: Codec 9 | build-type: Simple 10 | cabal-version: >=1.8 11 | description: 12 | QR Code encoder (and future decoder) in pure Haskell. 13 | 14 | data-files: TODO Example.hs README.markdown 15 | 16 | source-repository head 17 | type: git 18 | location: https://github.com/kizzx2/haskell-qrcode 19 | 20 | flag Prof 21 | default: False 22 | 23 | library 24 | exposed-modules: Codec.Binary.QRCode 25 | 26 | other-modules: Codec.Binary.QRCode.Blocks, 27 | Codec.Binary.QRCode.FormatInfo, 28 | Codec.Binary.QRCode.GaloisField, 29 | Codec.Binary.QRCode.Masks, 30 | Codec.Binary.QRCode.Matrix, 31 | Codec.Binary.QRCode.Placement, 32 | Codec.Binary.QRCode.Spec, 33 | Codec.Binary.QRCode.Utils, 34 | Codec.Binary.QRCode.VersionInfo, 35 | Codec.Binary.QRCode.Modes.Numeric, 36 | Codec.Binary.QRCode.Modes.Alphanumeric, 37 | Codec.Binary.QRCode.Modes.EightBit 38 | 39 | build-depends: base >= 4 && < 5, containers, array, mtl, vector 40 | ghc-options: -Wall 41 | 42 | test-suite qrcode-test 43 | type: exitcode-stdio-1.0 44 | main-is: test.hs 45 | build-depends: base >= 4 && < 5, containers, array, mtl, vector, 46 | hedgehog, hedgehog-quickcheck, exceptions 47 | ghc-options: -Wall -threaded -O2 48 | hs-source-dirs: test, . 49 | other-modules: Codec.Binary.QRCode, 50 | Codec.Binary.QRCode.Blocks, 51 | Codec.Binary.QRCode.FormatInfo, 52 | Codec.Binary.QRCode.GaloisField, 53 | Codec.Binary.QRCode.Masks, 54 | Codec.Binary.QRCode.Matrix, 55 | Codec.Binary.QRCode.Placement, 56 | Codec.Binary.QRCode.Spec, 57 | Codec.Binary.QRCode.Utils, 58 | Codec.Binary.QRCode.VersionInfo, 59 | Codec.Binary.QRCode.Modes.Numeric, 60 | Codec.Binary.QRCode.Modes.Alphanumeric, 61 | Codec.Binary.QRCode.Modes.EightBit 62 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: lts-20.22 19 | 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # - location: 27 | # git: https://github.com/commercialhaskell/stack.git 28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # extra-dep: true 31 | # subdirs: 32 | # - auto-update 33 | # - wai 34 | # 35 | # A package marked 'extra-dep: true' will only be built if demanded by a 36 | # non-dependency (i.e. a user package), and its test suites and benchmarks 37 | # will not be run. This is useful for tweaking upstream packages. 38 | packages: 39 | - . 40 | # Dependency packages to be pulled from upstream that are not in the resolver 41 | # (e.g., acme-missiles-0.3) 42 | extra-deps: [] 43 | 44 | # Override default flag values for local packages and extra-deps 45 | flags: {} 46 | 47 | # Extra package databases containing global packages 48 | extra-package-dbs: [] 49 | 50 | # Control whether we use the GHC we find on the path 51 | # system-ghc: true 52 | # 53 | # Require a specific version of stack, using version ranges 54 | # require-stack-version: -any # Default 55 | # require-stack-version: ">=1.5" 56 | # 57 | # Override the architecture used by stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor 67 | -------------------------------------------------------------------------------- /Codec/Binary/QRCode.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Codec.Binary.QRCode 3 | -- License : BSD3 4 | -- 5 | -- Maintainer : chris@kizzx2.com 6 | -- Stability : Experimental 7 | -- Portability : Portable 8 | -- 9 | -- An evolving QR Code encoder (and future decoder) in pure Haskell. 10 | -- 11 | -- Currently supports encoding 'Numeric', 'Alphanumeric', and 'EightBit' data. 12 | -- 13 | -- Example 14 | -- 15 | -- > encode (fromJust $ version 1) M Alphanumeric "hello world" 16 | 17 | module Codec.Binary.QRCode 18 | ( 19 | -- * Operations 20 | encode 21 | , toArray 22 | , width 23 | 24 | -- * Data Constructors 25 | , version 26 | 27 | -- * Data Types 28 | , Matrix 29 | , Module(..) 30 | , Mode(Numeric, Alphanumeric, EightBit) 31 | , ErrorLevel(..) 32 | , Version 33 | ) where 34 | 35 | import Codec.Binary.QRCode.Utils 36 | import Codec.Binary.QRCode.Spec 37 | import Codec.Binary.QRCode.Placement 38 | import Codec.Binary.QRCode.Masks 39 | import Codec.Binary.QRCode.Blocks 40 | import Codec.Binary.QRCode.Matrix 41 | 42 | import qualified Codec.Binary.QRCode.Modes.Numeric as N 43 | import qualified Codec.Binary.QRCode.Modes.Alphanumeric as A 44 | import qualified Codec.Binary.QRCode.Modes.EightBit as E 45 | import qualified Codec.Binary.QRCode.FormatInfo as F 46 | import qualified Codec.Binary.QRCode.VersionInfo as V 47 | 48 | import Control.Monad.Reader 49 | 50 | -- | Returns 'Nothing' if the input is invalid for the 'Mode' specified. 51 | encode :: Version -> ErrorLevel -> Mode -> String -> Maybe Matrix 52 | encode ver ecl mode input = 53 | inputEncode ver input >>= return . encode' ver ecl 54 | where 55 | inputEncode = case mode of 56 | Numeric -> N.encode 57 | Alphanumeric -> A.encode 58 | EightBit -> E.encode 59 | Kanji -> undefined 60 | 61 | encode' :: Version -> ErrorLevel -> BitStream -> Matrix 62 | encode' ver ecl encodedInput = final' 63 | where 64 | bitstream = interleave ver ecl encodedInput 65 | modules = toModules bitstream 66 | (matrix,maskRef) = runReader (mask modules) ver 67 | 68 | format = F.encode ecl maskRef 69 | ver' = V.encode ver 70 | 71 | final = qrmApplyFormatInfo ver matrix format 72 | final' = qrmApplyVersionInfo ver final ver' 73 | 74 | -- | The number of modules per side. 75 | width :: Matrix -> Int 76 | width = qrmWidth 77 | 78 | -- | Valid version number is /[1, 40]/ 79 | version :: Int -> Maybe Version 80 | version n | n >= 1 && n <= 40 = Just (Version n) 81 | | otherwise = Nothing 82 | -------------------------------------------------------------------------------- /Codec/Binary/QRCode/Blocks.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK hide #-} 2 | 3 | module Codec.Binary.QRCode.Blocks where 4 | 5 | import Codec.Binary.QRCode.Utils 6 | import Codec.Binary.QRCode.Spec 7 | import Codec.Binary.QRCode.GaloisField 8 | 9 | import Control.Monad 10 | 11 | type Codewords = [BitStream] 12 | 13 | mkPolyForEncode :: Version -> ErrorLevel -> BitStream -> GFPolynomial 14 | mkPolyForEncode (Version v) errLevel bitstream = gfpRightPad numErrorWords $ mkPolynomial $ map readBin $ chunksOf 8 bitstream 15 | where numErrorWords = qrNumErrorCodewordsPerBlock v errLevel 16 | 17 | interleave :: Version -> ErrorLevel -> BitStream -> BitStream 18 | interleave ver@(Version v) ecl rawCoded = result' 19 | where 20 | blocks :: [[BitStream]] 21 | blocks = chunks (chunksOf 8 $ mkDataCodewords ver ecl rawCoded) (qrDCWSizes v ecl) 22 | 23 | codewordPairs = map (genCodewords ver ecl . concat) blocks 24 | 25 | dataCodewords :: [[BitStream]] 26 | dataCodewords = map fst codewordPairs 27 | 28 | ecCodewords :: [[BitStream]] 29 | ecCodewords = map snd codewordPairs 30 | 31 | padRemainderBits i' = i' ++ take (qrRemainderBits info) "0000000" 32 | 33 | info = qrGetInfo ver 34 | result = concat $ concat (transpose dataCodewords) ++ concat (transpose ecCodewords) 35 | result' = padRemainderBits result 36 | 37 | pad :: MonadPlus m => [[m a]] -> [[m a]] 38 | pad xs = map go xs 39 | where 40 | go l = take len $ l ++ repeat mzero 41 | len = maximum . map length $ xs 42 | 43 | transpose :: [[a]] -> [[a]] 44 | transpose xs = foldl1 (zipWith mplus) xs' 45 | where xs' = pad $ map (map (:[])) xs 46 | 47 | chunks :: [a] -> [Int] -> [[a]] 48 | chunks = go [] 49 | where 50 | go acc xs (n:ns) = go (take n xs : acc) (drop n xs) ns 51 | go acc _ [] = reverse acc 52 | 53 | toCodewords :: BitStream -> Codewords 54 | toCodewords = chunksOf 8 55 | 56 | genCodewords :: Version -> ErrorLevel -> BitStream -> (Codewords, Codewords) 57 | genCodewords ver@(Version v) ecl input = (toCodewords dataCodewords, toCodewords errorCodewords) 58 | where 59 | dataCodewords = input 60 | 61 | numErrorWords = qrNumErrorCodewordsPerBlock v ecl 62 | genPoly = mkPolynomial $ qrGenPoly numErrorWords 63 | 64 | poly = toECPoly ver ecl dataCodewords 65 | errorCodewords = gfpShowBin $ snd $ gfpQuotRem poly genPoly 66 | 67 | mkDataCodewords :: Version -> ErrorLevel -> BitStream -> BitStream 68 | mkDataCodewords (Version v) errLevel = fillPadCodewords . padBits . terminate 69 | where 70 | numDataBits = qrNumDataBits v errLevel 71 | terminate i' = i' ++ take (numDataBits - length i') "0000" 72 | padBits i' = i' ++ take padLength "0000000" 73 | where padLength = 8 - (length i' `rem` 8) 74 | fillPadCodewords i' = take numDataBits (i' ++ cycle "1110110000010001") 75 | 76 | toECPoly :: Version -> ErrorLevel -> BitStream -> GFPolynomial 77 | toECPoly (Version v) errLevel bitstream = gfpRightPad numErrorWords $ mkPolynomial $ map readBin $ chunksOf 8 bitstream 78 | where numErrorWords = qrNumErrorCodewordsPerBlock v errLevel 79 | -------------------------------------------------------------------------------- /Codec/Binary/QRCode/Masks.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK hide #-} 2 | module Codec.Binary.QRCode.Masks where 3 | 4 | import Codec.Binary.QRCode.Spec 5 | import Codec.Binary.QRCode.Utils 6 | import Codec.Binary.QRCode.Placement 7 | import Codec.Binary.QRCode.Matrix 8 | 9 | import Control.Monad.Reader 10 | 11 | import Data.Function 12 | 13 | import Data.Array.IArray 14 | import Data.List 15 | 16 | type Block = [(Int,Int)] 17 | 18 | mask000Cond, mask001Cond, mask010Cond, mask011Cond, mask100Cond, mask101Cond, mask110Cond, mask111Cond :: Integral a => a -> a -> Bool 19 | mask000Cond i j = (i+j) `mod` 2 == 0 20 | mask001Cond i _ = i `mod` 2 == 0 21 | mask010Cond _ j = j `mod` 3 == 0 22 | mask011Cond i j = (i+j) `mod` 3 == 0 23 | mask100Cond i j = ((i`div`2) + (j`div`3)) `mod` 2 == 0 24 | mask101Cond i j = (i*j) `mod` 2 + (i*j) `mod` 3 == 0 25 | mask110Cond i j = ((i*j) `mod` 2 + (i*j) `mod` 3) `mod` 2 == 0 26 | mask111Cond i j = ((i*j) `mod` 3 + (i+j) `mod` 2) `mod` 2 == 0 27 | 28 | mkMask :: (Int -> Int -> Bool) -> [(Int, Int)] -> ReaderQR [Module] 29 | mkMask cond coords = do 30 | ver <- ask 31 | let width = qrGetWidth ver 32 | -- FIXME we need to convert a bottom right coord to top left coord, ARGH! 33 | let unnatural n = width - 1 - n 34 | transform (i,j) = if (cond `on` unnatural) i j then Dark else Light 35 | return $ map transform coords 36 | 37 | mask000, mask001, mask010, mask011, mask100, mask101, mask110, mask111 :: Coords -> ReaderQR Modules 38 | mask000 = mkMask mask000Cond 39 | mask001 = mkMask mask001Cond 40 | mask010 = mkMask mask010Cond 41 | mask011 = mkMask mask011Cond 42 | mask100 = mkMask mask100Cond 43 | mask101 = mkMask mask101Cond 44 | mask110 = mkMask mask110Cond 45 | mask111 = mkMask mask111Cond 46 | 47 | mask :: Modules -> ReaderQR (Matrix, BitStream) 48 | mask mods = do 49 | ver <- ask 50 | coords <- mkPath 51 | masks <- sequence $ [mask000, mask001, mask010, mask011, mask100, mask101, mask110, mask111] <*> pure coords 52 | let maskRefs = ["000", "001", "010", "011", "100", "101", "110", "111"] 53 | mkMaskedSym x y = mkSymbol coords ver $ applyMask x y 54 | syms = zipWith mkMaskedSym (repeat mods) masks 55 | symsWithRefsScores = zip (map score syms) $ zip syms maskRefs-- (score,(sym,ref)) 56 | best = minimumBy (compare `on` fst) symsWithRefsScores 57 | return $ snd best 58 | 59 | applyMask :: Modules -> Modules -> Modules 60 | applyMask = zipWith qrXor 61 | 62 | -- run length encode 63 | rle :: (Eq a) => [a] -> [(a,Int)] 64 | rle = foldl' go [] 65 | where 66 | go [] x = [(x,1)] 67 | go acc@((y,n):ys) x = if x == y then (y,n+1):ys else (x,1):acc 68 | 69 | score :: Matrix -> Int 70 | score mat = sum . zipWith ($) funcs . repeat $ mat 71 | where 72 | funcs = [ scoreRule1 rows cols 73 | , all2x2Blocks 74 | , countFinderRatio rows cols 75 | , proportionOfDarkModules 76 | ] 77 | width = qrmWidth mat 78 | rows = [qrmRow n mat | n <- [0..width] ] 79 | cols = [qrmCol n mat | n <- [0..width] ] 80 | 81 | -- Adjacent modules in row/column in same color 82 | scoreRule1 :: Eq a => [[a]] -> [[a]] -> t -> Int 83 | scoreRule1 rows cols _ = sumOver rows + sumOver cols 84 | where 85 | sumOver = sum . map countOne 86 | countOne = sum . map (subtract 2) . filter (>5) . map snd . rle -- -5 + 3 (N1) = -2 87 | 88 | all2x2Blocks :: Matrix -> Int 89 | all2x2Blocks mat = 3 * total 90 | where 91 | total = sum . map (sum . map fromEnum) $ blockRows 92 | width = qrmWidth mat 93 | mods = getModules mat 94 | 95 | blockRows :: [[Bool]] 96 | blockRows = [zipWith go (statusRows !! n) (statusRows !! (n+1)) | n <- [0..width-1]] 97 | where 98 | go :: Int -> Int -> Bool 99 | go a b = a == b && a /= 0 100 | 101 | statusRows = [rowToStatuses n | n <- [0..width]] 102 | calcStatus (a,b) = 103 | if mods ! a == mods ! b 104 | then if mods ! a == Light then bothLight else bothDark 105 | else different 106 | rowToStatuses n = map calcStatus $ pairsOfRow n 107 | pairsOfRow n = [((n,x),(n,x+1)) | x <- [0..width-1]] 108 | 109 | different = 0 110 | bothLight = -1 111 | bothDark = 1 112 | 113 | countFinderRatio :: Num a => [[Module]] -> [[Module]] -> t -> a 114 | countFinderRatio rows cols _ = (sum rowCounts + sum colCounts) * 40 115 | where 116 | rowCounts = map count rows 117 | colCounts = map count cols 118 | 119 | count = go 0 120 | 121 | go acc (Dark:Light:Dark:Dark:Dark:Light:Dark:xs) = go (acc+1) (Dark:xs) 122 | go acc (_:xs) = go acc xs 123 | go acc [] = acc 124 | 125 | proportionOfDarkModules :: Matrix -> Int 126 | proportionOfDarkModules mat = total 127 | where 128 | total = 10 * k 129 | k = truncate $ abs (0.5 - proportion) / 0.05 130 | 131 | proportion :: Double 132 | proportion = ((/) `on` fromIntegral) (numDarks mat) numModules 133 | 134 | numModules :: Int 135 | numModules = (qrmWidth mat + 1) ^ (2 :: Int) 136 | 137 | numDarks = sum . map darkToOne . elems . getModules 138 | 139 | darkToOne Dark = 1 140 | darkToOne _ = 0 141 | -------------------------------------------------------------------------------- /Codec/Binary/QRCode/GaloisField.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK hide #-} 2 | module Codec.Binary.QRCode.GaloisField where 3 | 4 | import Data.Bits 5 | 6 | import Numeric hiding (readBin, showBin) 7 | import Data.Char 8 | 9 | import qualified Data.Map as M 10 | import qualified Data.Vector.Unboxed as VU 11 | 12 | qrGFSize :: Int 13 | qrGFSize = 256 -- QR code symbols are GF(2^8) 14 | 15 | qrFieldPolynomial :: Int 16 | qrFieldPolynomial = 285 -- 100011101, from the standard 17 | 18 | readBin :: String -> Int 19 | readBin s = go 0 0 (reverse s) 20 | where 21 | go :: Int -> Int -> String -> Int 22 | go acc _ "" = acc 23 | go acc pow ('0':xs) = go acc (pow+1) xs 24 | go acc pow ('1':xs) = go (acc + 2 ^ pow) (pow+1) xs 25 | go _ _ xs = error $ "Malformed binary string '" ++ xs ++ "'" 26 | 27 | newtype GFElement = GFElement { gfGet :: Int } deriving (Eq) 28 | newtype GFPolynomial = GFPolynomial { gfpGetTerms :: [GFElement] } deriving (Show, Eq) 29 | type GFPTerm = (GFElement, Int) -- (coefficient, order) 30 | 31 | instance Show GFElement where 32 | show (GFElement x) = "GFE " ++ show x 33 | 34 | gfAdd :: GFElement -> GFElement -> GFElement 35 | gfAdd (GFElement x) (GFElement y) = GFElement (x `xor` y) 36 | 37 | gfMinus :: GFElement -> GFElement -> GFElement 38 | gfMinus = gfAdd 39 | 40 | gfALogs :: [Int] 41 | gfALogs = 1 : map f gfALogs 42 | where 43 | f x = let x' = x * 2 in 44 | if x' >= qrGFSize 45 | then x' `xor` qrFieldPolynomial 46 | else x' 47 | 48 | gfALogsVec :: VU.Vector Int 49 | gfALogsVec = VU.fromList . take 255 $ gfALogs 50 | 51 | gfALog :: Int -> Int 52 | gfALog = (gfALogsVec VU.!) . (`mod` 255) 53 | 54 | gfLogs :: M.Map Int Int 55 | gfLogs = M.fromList $ take qrGFSize $ zip gfALogs [0..] 56 | 57 | gfLog :: Int -> Int 58 | gfLog = (M.!) gfLogs 59 | 60 | gfMult :: GFElement -> GFElement -> GFElement 61 | gfMult z@(GFElement 0) _ = z 62 | gfMult _ z@(GFElement 0) = z 63 | gfMult x (GFElement 1) = x 64 | gfMult (GFElement 1) x = x 65 | gfMult (GFElement x) (GFElement y) = 66 | GFElement $ gfALog(gfLog x + gfLog y) `mod` qrGFSize 67 | 68 | gfQuot :: GFElement -> GFElement -> GFElement 69 | gfQuot x (GFElement 1) = x 70 | gfQuot _ (GFElement 0) = error "div by zero" 71 | gfQuot (GFElement x) (GFElement y) = 72 | GFElement $ gfALog(gfLog x - gfLog y + (qrGFSize-1)) `mod` (qrGFSize-1) 73 | 74 | instance Num GFElement where 75 | (+) = gfAdd 76 | (-) = gfMinus 77 | (*) = gfMult 78 | negate = id 79 | abs = id 80 | signum = const $ GFElement 1 81 | fromInteger = GFElement . fromInteger 82 | 83 | gfShowBin :: GFElement -> String 84 | gfShowBin (GFElement n) = replicate padLength '0' ++ str 85 | where str = showIntAtBase 2 intToDigit n "" 86 | padLength = 8 - length str 87 | 88 | gfQuotRem :: GFElement -> GFElement -> (GFElement, GFElement) 89 | gfQuotRem x y = let q = gfQuot x y in (q, x - q) 90 | 91 | gfpOrder :: GFPolynomial -> Int 92 | gfpOrder (GFPolynomial terms) = length terms - 1 93 | 94 | gfZeroes :: [GFElement] 95 | gfZeroes = repeat (GFElement 0) 96 | 97 | gfpEnlarge :: Int -> GFPolynomial -> GFPolynomial 98 | gfpEnlarge n p@(GFPolynomial terms) 99 | | order >= n = p 100 | | otherwise = GFPolynomial $ take (n-order) gfZeroes ++ terms 101 | where order = gfpOrder p 102 | 103 | gfpShowBin :: GFPolynomial -> String 104 | gfpShowBin (GFPolynomial xs) = concatMap gfShowBin xs 105 | 106 | gfpHead :: GFPolynomial -> GFElement 107 | gfpHead = head . gfpGetTerms 108 | 109 | gfpZipWith :: (GFElement -> GFElement -> GFElement) -> GFPolynomial -> GFPolynomial -> GFPolynomial 110 | gfpZipWith f a b = GFPolynomial $ dropWhile (== GFElement 0) $ zipWith f aTerms bTerms 111 | where 112 | maxOrder = max (gfpOrder a) (gfpOrder b) 113 | (GFPolynomial aTerms) = gfpEnlarge maxOrder a 114 | (GFPolynomial bTerms) = gfpEnlarge maxOrder b 115 | 116 | gfpAdd :: GFPolynomial -> GFPolynomial -> GFPolynomial 117 | gfpAdd = gfpZipWith (+) 118 | 119 | gfpMinus :: GFPolynomial -> GFPolynomial -> GFPolynomial 120 | gfpMinus = gfpZipWith (-) 121 | 122 | gfpMultTerm :: GFPolynomial -> GFPTerm -> GFPolynomial 123 | gfpMultTerm (GFPolynomial terms) (coefficient,order) = 124 | GFPolynomial $ map (*coefficient) (terms ++ take order gfZeroes) 125 | 126 | gfpAddTerm :: GFPolynomial -> GFPTerm -> GFPolynomial 127 | gfpAddTerm p (coefficient, order) = gfpZipWith (+) p additive 128 | where 129 | additive = GFPolynomial $ coefficient : take order gfZeroes 130 | 131 | gfpQuotRem :: GFPolynomial -> GFPolynomial -> (GFPolynomial, GFPolynomial) 132 | gfpQuotRem dividend divisor = go dividend (GFPolynomial []) 133 | where 134 | divHead = gfpHead divisor 135 | go currentDividend q 136 | | order < 0 = (q, currentDividend) 137 | | gfpOrder nextDividend == 0 = (q', GFPolynomial []) 138 | | otherwise = 139 | go nextDividend (q |+| currentTerm) 140 | where 141 | nextDividend = currentDividend |-| currentQuotient 142 | q' = q |+| currentTerm 143 | 144 | coefficient = gfQuot (gfpHead currentDividend) divHead 145 | order = gfpOrder currentDividend - gfpOrder divisor 146 | currentTerm = (coefficient,order) 147 | currentQuotient = divisor |*| currentTerm 148 | (|-|) = gfpMinus 149 | (|*|) = gfpMultTerm 150 | (|+|) = gfpAddTerm 151 | 152 | gfpRightPad :: Int -> GFPolynomial -> GFPolynomial 153 | gfpRightPad n (GFPolynomial terms) = GFPolynomial $ terms ++ replicate n 0 154 | 155 | mkPolynomial :: [Int] -> GFPolynomial 156 | mkPolynomial = GFPolynomial . map GFElement 157 | 158 | gfpToBinaryRepr :: GFPolynomial -> Int 159 | gfpToBinaryRepr (GFPolynomial terms) = readBin bits 160 | where bits = concatMap (show . gfGet) terms 161 | -------------------------------------------------------------------------------- /test/test.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK hide #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | 6 | import System.IO (BufferMode(..), hSetBuffering, stdout, stderr) 7 | import System.Exit (exitFailure) 8 | import Data.Maybe (isJust, fromJust) 9 | import Control.Monad (unless) 10 | import Control.Monad.Catch (MonadCatch(..)) 11 | import Hedgehog 12 | import qualified Hedgehog.Gen as Gen 13 | import qualified Hedgehog.Range as Range 14 | import Data.Array 15 | import Codec.Binary.QRCode 16 | 17 | 18 | shortFailures :: [(Int, ErrorLevel, Mode, String)] 19 | shortFailures = 20 | -- https://github.com/kizzx2/haskell-qrcode/issues/7 21 | [ (1, H, Numeric, "268") 22 | -- https://github.com/kizzx2/haskell-qrcode/issues/5 23 | , (40, L, Alphanumeric, "16-KVRR2GX*O31Z4OPG.V.1U:L439+IO6GBLHXE5XBU-VML$84-K %NQ6Z ED000N9I.3.TV:QBSNUU000SAX3V%D+1NZL:Q7:R0G27ODAPBAS6X XJKX KBIBZSU647720$1K*I$3QU2D79FOLJ $WP5T9SH%A2L%J*L::*B$Q$9V3ITWSMYRFZGM1BT+2KYPXA+RIFS1O*SLB8*VN1W-XD*ZH%IN:JGDU5TJ:STH3T$ 3DQHRHL2C*535$*UA4PV+5::3E.S$U:84N6SL*.1$5QEBS$7*F2YG.U2B$B6E26480:+RQ$ZG2E*7G$%SW7%5KZVPYIQ76A-$D+:71:H:PQOU51O8W9C%KMBD8IWDKB$AMVNKO5N09S4D3JSYR LVDYVDB4 V*T4VYH$D3D0RE3KAN:RP6LGJZYN*H5TF34W%SX:ZV216Y XY%.CUN0CDT15+1LE1Z9TNV+0B1:O2D2:300RW1NHJMYT.BW+4UQED0W.FSI4%MQC8X-GEQY:8LHO5ID%O8I8MT.%2YNC21MJCNML.M4I1J3PM-$1R01VANGOS.TIZRF8 C+WY:8%SN0CK+VD8*O*KWVFX7WPZ:SN$C93RYM$2+NLA%CO:9NDM7WZ*-DU9ZY45C:412HDEY%MN4O2-:::*I4TC2411NPZ$.YF7VQ.UORG:Z5 :4M:.:33HU*$R12+*USGHY%.E35WPYKAZI$8L74:TQ7AZZ+AYV8NDBPUU$2 YD%*W8Y%O24 B-MAU+%+5$2 6.1I+DNZY*-14J$R %N6SHD05SD*A54KA$43AG92T %3:8:A9ZCQSPNS5YRY$ZKUKJ$%LI$%0H:48+:PN*AAY%SG+Y:KS .BDU6HO:NY7*Q:ZB$6N4 ZRBEA6K328$+35JMPFY-T6:13PTM*6O%2 +AOKEG:-T6UUC+OZ8H:*TUAYUN*W329R8:C7**KSEVHW7O$CW 82QUF4FXE6LI5GOH :-C 0 0L*6WT59V1:RBMX0SL2.1DYH-0P3XS%:-MOVJWWK--MTQ+K40BZZ8O4BF2MFHZ9X6VXYB-OLEH-9.JX0FB+KL38UM7:M84WVAU1:M2YBTJ5WWK5-7WI65J*5CG58:%JAO9B3D+AMF1:*NQBQ3:+:RFK2SL829IKH*E*AEAXEAQVG7Z+CMU$EK3.512EHZTV*A:UPC69JB77G4.NH5.UT.53:ETBA3Y1CMFLXD11:Z*E%8%5$X5G08ECC-2K:3ANLBP*O.%1PI$U:$XEB*%IJ0JY .N::IDVDFKP8M E.91UIMXL+WT6%6TKW0$6 W:P-*J%JN4$-U2OLL+1FIX8UIBWHNN:PB0HDOOECAW5M1AOW%CIXDMXFO6J-EV0B:Q%8C44DCN:-OT6ODW9-KDDF1AC0NPS5IJ8MEGR41%KBDX2LC:*ROM5RB$1Q 1VOW*8N9-P8$M686TL4P+EIJ117KNSZ9B0E8M79DGS-:GDN1H56I-8YQ697O2C3R5$0E2ZRXH*IJ.J.*ULC %5BYBQ66F5AVQ+UZA3Q$T%3-W4VWWLWO ZDE4DFUA6VWKLTD*LD6+UBDTYU+LJMN.341 4 0XW%EG:M+7VCXSOZT$G1MD-TS6JG.%D4SEBL5AA-4T W9D.BE*4G0:3*ZF2*KO::7FS2C.+7K0.LERFQ7HOZPCYYS8RNS%+PNDS 4BJM6C3BLB7J-J:K+N573QOX.JPY8IL M7I6MBZDX8VXTLBUEEUHJGJN%K+OJEUV2HFSMQ5PLMDE$AEN.WN2S0I1V52-6$Q6A41A8-7KIBI6:L7177AI5YVR2PQW EM%D MZ7BI6VTF:PO0W7QKG3-RBKKFEP62OPA%AQEM.%974ON5.HQOEMDC3Y:3GKT$0PV%UCNTUJO.9KCLTZ53*VD97V+MFBZ90UHDR ZQ V*9- HQOJ31BT36+66G1M:YEE8Q3N:97T4WU8G:TW%V8-6O%GTOEAEM74.H8IIUM::XYZL4VPIINMLZJEH4J1UBBOP%71:Z+-0VWYRVI817-1I4ZW+K0%6N628%E.2UBEJC74IIH7 :CYN30FG+P99ABEQ*O 0X40MKY8S6MQ3CVKR402Q8J73:90$N07V68:F9K3TCZOY0EU*V4:.L3ES6KSG6U0:C0.*D$DWMT0CT8-F933 L3 XT1HHJZVSCRY:6.D$KOC5UGX4:+H0*0BOI%ZYK:F*AH-:4K7XJ$K9%TE6XKNN GD U+F1S 08-S$5:E0J943VP2SGH2RO3CGPYSK78 8TB61T-R0P$9SY.%Z1:A-% 4VZ0AKXKC-6KE:16N573B-$IK2M5 D*P$SBBQOPYSG IA2U-:01S:A..BMVOBX68C:A87D*8JQ5UVD*7-RF*M7EX%CM%VLO85LQ2ODJ9ADRS$3::FT-C4:V:1%94FOCSQ* 0RS$ABC:YGIW---KD:6K1$LILPMWSMYVW0T:*7SFX W3L8ME9:X:4%VQF%SN70X9O C%N8J2SX*:$H5%B-3$*M-:LZ:1226$.AE.+W+MBJQI3.IE$-H5O3GX41U4XH6:6ZK5LE F+Z6TIX.TYLWGFM1DOE7FC*M*0ZKWIC+XD5TA*CALTR3+A+8GO$$*UQ-PD7G 8QWQ462CK0C2UWU-+:QN+ZSD O7DMG3G:449EPC7D3B%PO::D2V4CZ H%RHUXZDM$XWO$U-X-7A2Y6V7EMP.:G4IY57 0V0JM:OVN+6I::42J:8Z5PP2NY2G4G$25FHGD:1C03:FU$QZ5QD7FPPD5CR9H00J0L1PMO9RF2EBNVA6S:14W8JYA4YYY2 -ZPMM-F4EB238.371Z8FRJY$9I0 OP$ QCVCF+Y8DSQMY8O0P0904T-XQ1.-HD22K2M6MGU.2KWHJ9GTYD Z9HE4SHS90TUPT5TGLS64TG7HYO%*QM$80Q:O4YIPCCL6LWF676TW3T.Z.T6M5*-Z$4T4O$ 0IPYSZSU*D528U.4I1KGQF-G$H40C0UWRL X05U4:ZFR.2FF$OZ6G:ZHC6182 *$0NG+*PK.L6R7N280RDX4LDS16:J-KT1DXA N4ZZS02JULC90H4U8MSE6:WE-*I CV:ER*+R912DGRKT$MLH:B209CW319$-YA.1STH16UIRJ9IZ-YRE*HIX3+:0%BVM.3K+ D7.C.LV++YG.0L0Y7:*70I*L+N%P2EAW56:LRK1IX0K$EV0+VTDUT4V Y3MTF+W.*KWMDJZBXZI2 A.O5 PVI-4+IU$ +.M8CVV1:T-63FLB8HONIBTURTQXGWLFZVRH8LM$%WEF$6$MN$PORKEVNX*GQ J4XTCMOD-:$:DZE4L6+R07A1V1V:DOYY M0:RF1*OY.*-RXRY-:O5UHDUMSMIKVT1AZEA-OI7OS*59 S4E320X4BC$GZJP:9S412.DJ9Z3D2*:2RT2I9D+TR7F7P 1$15GVRDZ.DW-689JF5H:0NRNMUHO2LY+.LQ49:JNC6XQ:-9 XU67IPLJPH2*XL3E6LJM*XVLJ%K%2N9I09RT2:T5CLTI:63-EQ*O:0G4W:HH$QPT::+9*E10R4ON+6S960:CSP57C.TNZ7P6LM$TA9.U%B5.U*VSW0ERV1AX.MP-X70AAEG0O5: CD-UE2AMFOU-+5ZTRPQK:YU7QCZ X$N.M.CQ4+ N26R8XO3WA2IKRUPJMIQLMKNLG.BY1DF%0$U3A:CIX- C4LE6E9E9AQ8WFMC*O:*SEIF:1X495TAK81E0-OCR4DKTJ2WGUFC2S.:9:D0HL:EE+.4C.F5G02Y+$P*-7M+ 1ILQAXGL%D61TX2XA7YK8DK:QL82GHB5B5UAD:8*$06T:+5TL*.8:2KP6J:10N30FFXWP4T%QVXC%:4G:U:75-:9:2:W*DOPVAAW0%FC%S ROZV31.BA$SLOHQBI.A1B5DE2G+.0GA XGTJFAFX*H9CR03Z75CRIXAPA56I+LJ7HFGPQ2K%P.*XF.IJO:Y E3.Q-:%86:*I3P NP7FV714-SOQ $5 :17P.HSQ8Q3TDXTU08%2KPRZHD%2HFJEUOK+U:TT*QTK00M:+4U59B68*A67PZ2LY%I:XE7 R0S-FMS.D7RY3DE.%GKB2S 9VV.9%WN NHKJN-SFKJF7KI3G8BZ8EA1%C6D U:-6A50X6F-QAX*E.3PPAU0HRDHLPF:%W*WPJ3-W%U*:4M6X48:O63.G077C.2UVYODRUL:E:YY+NF31AJ2WU") 24 | -- https://github.com/kizzx2/haskell-qrcode/issues/1 25 | , (15, L, Alphanumeric, "HELLO WORLD HELLO WORLD HEHELLO WORLD HELLO WORLD HEHELLO WORLD HELLO WORLD HEHELLO WORLD HELLO WORLD HEHELLO WORLD HELLO WORLD HEHELLO WORLD HELLO WORLD HEHELLO WORLD HELLO WORLD HEHELLO WORLD HELLO WORLD HEHELLO WORLD HELLO WORLD HEHELLO WORLD HELLO WORLD HE") 26 | , (7, Q, EightBit, "\NUL") 27 | , (5, Q, EightBit, "\NUL\NUL\NUL\NUL\NUL\NUL") 28 | , (2, Q, Alphanumeric, "0PA8M") 29 | , (4, H, Alphanumeric, "AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAN5XMFYZDNCM5UH") 30 | , (13, Q, Alphanumeric, "T1JPZRXUGST$M%::J") 31 | , (16, H, Alphanumeric, "0000000000000000000000000000000000000000000000000000000000000000") 32 | , (7, M, Numeric, "7038935389817588382403234418665196039788216355301578947135350196854") 33 | ] 34 | 35 | alphaNumeric :: Gen Char 36 | alphaNumeric = Gen.element "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ $%*+-./:" 37 | 38 | assertMatrix :: (MonadTest m, MonadCatch m) => Maybe Matrix -> m () 39 | assertMatrix m = do 40 | assert . isJust $ m 41 | -- Collect all of the undefined indices 42 | let arr = toArray (fromJust m) :: Array (Int, Int) Bool 43 | evalM $ mapM_ (\e -> e `seq` pure ()) (elems arr) 44 | 45 | prop_shortFailures :: Property 46 | prop_shortFailures = 47 | property $ do 48 | (v, e, m, s) <- forAll $ Gen.element shortFailures 49 | assertMatrix $ encode (fromJust $ version v) e m s 50 | 51 | prop_encode_alphanumeric :: Property 52 | prop_encode_alphanumeric = 53 | property $ do 54 | Just ver <- forAll $ version <$> Gen.int (Range.linear 2 20) 55 | e <- forAll $ Gen.element [ L, M, Q, H ] 56 | s <- forAll $ Gen.string (Range.linear 1 1000) alphaNumeric 57 | assertMatrix $ encode ver e Alphanumeric s 58 | 59 | prop_encode_numeric :: Property 60 | prop_encode_numeric = 61 | property $ do 62 | Just ver <- forAll $ version <$> Gen.int (Range.linear 2 20) 63 | e <- forAll $ Gen.element [ L, M, Q, H ] 64 | s <- forAll $ Gen.string (Range.linear 1 1000) Gen.digit 65 | assertMatrix $ encode ver e Numeric s 66 | 67 | prop_encode_eightbit :: Property 68 | prop_encode_eightbit = property $ do 69 | Just ver <- forAll $ version <$> Gen.int (Range.linear 4 20) 70 | e <- forAll $ Gen.element [ L, M, Q, H ] 71 | s <- forAll $ Gen.string (Range.linear 1 1000) Gen.latin1 72 | assertMatrix $ encode ver e EightBit s 73 | 74 | tests :: IO Bool 75 | tests = 76 | checkParallel $$(discover) 77 | 78 | main :: IO () 79 | main = do 80 | hSetBuffering stdout LineBuffering 81 | hSetBuffering stderr LineBuffering 82 | result <- tests 83 | unless result exitFailure 84 | -------------------------------------------------------------------------------- /Codec/Binary/QRCode/Placement.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK hide #-} 2 | {-# LANGUAGE FlexibleContexts, GeneralizedNewtypeDeriving, NoMonomorphismRestriction #-} 3 | 4 | module Codec.Binary.QRCode.Placement where 5 | 6 | import Codec.Binary.QRCode.Matrix 7 | import Codec.Binary.QRCode.Spec 8 | import Codec.Binary.QRCode.Utils 9 | 10 | import Data.Tuple 11 | import Data.List 12 | import qualified Data.Set as S 13 | 14 | import Control.Monad 15 | import Control.Monad.Reader 16 | 17 | import Data.Array.IArray 18 | 19 | type Coords = [(Int,Int)] 20 | type ReaderCoords = ReaderQR Coords 21 | type MatrixPart = [((Int,Int),Module)] 22 | 23 | intertwine :: [a] -> [a] -> [a] 24 | intertwine (x:xs) (y:ys) = x:y:intertwine xs ys 25 | intertwine (x:xs) [] = x:intertwine xs [] 26 | intertwine [] (y:ys) = y:intertwine [] ys 27 | intertwine [] [] = [] 28 | 29 | -- mkCleanBoardMatrix :: Int -> Matrix 30 | -- mkCleanBoardMatrix width = QRM $ array ((0,0), (width-1,width-1)) combined 31 | -- where 32 | -- finderTL = genFinderPatternTopLeft 33 | 34 | mkMatrix :: Int -> [((Int, Int), Module)] -> Matrix 35 | mkMatrix width = QRM . array ((0,0),(width-1,width-1)) 36 | 37 | mkSymbolWithFunctionPatterns :: Version -> Modules -> Matrix 38 | mkSymbolWithFunctionPatterns ver mods = mkMatrix width combinedMods 39 | where 40 | width = qrNumModulesPerSide $ qrGetInfo ver 41 | combinedMods = flip runReader ver $ do 42 | let genAllLight = liftM $ flip zip $ repeat Light 43 | 44 | formats <- formatInfoRegions 45 | versions <- versionInfoRegions 46 | finderTL <- genAllLight finderPatternTopLeft 47 | finderBL <- genAllLight finderPatternBottomLeft 48 | finderTR <- genAllLight finderPatternTopRight 49 | timingH <- genAllLight timingPatternHorizontal 50 | timingV <- genAllLight timingPatternVertical 51 | hardcoded <- hardcodedDarkModule 52 | 53 | path <- mkPath 54 | 55 | let dat = zip path mods 56 | finders = finderTL ++ finderBL ++ finderTR 57 | timings = timingH ++ timingV 58 | hc = zip hardcoded (repeat Light) 59 | 60 | -- These will be applied to the symbol after masking 61 | formats' = zip formats (repeat Light) 62 | versions' = zip versions (repeat Light) 63 | 64 | return $ dat ++ finders ++ timings ++ hc ++ formats' ++ versions' 65 | 66 | mkSymbol :: Coords -> Version -> Modules -> Matrix 67 | mkSymbol path ver mods = mkMatrix width combinedMods 68 | where 69 | width = qrNumModulesPerSide $ qrGetInfo ver 70 | combinedMods = flip runReader ver $ do 71 | formats <- formatInfoRegions 72 | versions <- versionInfoRegions 73 | finderTL <- genFinderPatternTopLeft finderPatternTopLeft 74 | finderBL <- genFinderPatternBottomLeft finderPatternBottomLeft 75 | finderTR <- genFinderPatternTopRight finderPatternTopRight 76 | timingH <- genTimingPattern timingPatternHorizontal 77 | timingV <- genTimingPattern timingPatternVertical 78 | alignments <- liftM genAlignmentPatterns alignmentCoords 79 | hardcoded <- hardcodedDarkModule 80 | let dat = zip path mods 81 | finders = finderTL ++ finderBL ++ finderTR 82 | timings = timingH ++ timingV 83 | hc = zip hardcoded [Dark] 84 | formats' = zip formats $ repeat Light 85 | versions' = zip versions $ repeat Light 86 | return $ dat ++ finders ++ timings ++ hc ++ formats' ++ alignments ++ versions' 87 | 88 | qrmApplyInfo :: ReaderQR Coords -> ReaderQR Coords -> Version -> Matrix-> BitStream -> Matrix 89 | qrmApplyInfo region1 region2 ver mat bitstream = qrmOverlay mat overlays 90 | where 91 | mods = toModules bitstream 92 | overlays = flip runReader ver $ do 93 | path1 <- region1 94 | path2 <- region2 95 | return $ zip path1 mods ++ zip path2 mods 96 | 97 | qrmApplyFormatInfo :: Version -> Matrix -> BitStream -> Matrix 98 | qrmApplyFormatInfo = qrmApplyInfo formatInfoRegionHorizontal formatInfoRegionVertical 99 | 100 | qrmApplyVersionInfo :: Version -> Matrix -> BitStream -> Matrix 101 | qrmApplyVersionInfo = qrmApplyInfo versionInfoRegionBottomLeft versionInfoRegionTopRight 102 | 103 | newtype MyChar = MC Char deriving (Eq, Ord, Enum) 104 | 105 | instance Show MyChar where 106 | show (MC '\n') = "\n" 107 | show (MC c) = [c] 108 | 109 | mkDebugPath :: Version -> Array (Int,Int) MyChar 110 | mkDebugPath ver = base // trail 111 | where 112 | width = qrNumModulesPerSide $ qrGetInfo ver 113 | ix = ((0,0),(width-1,width-1)) 114 | blanks = repeat (MC ' ') 115 | trail = zip (runReader mkPath ver) $ cycle $ reverse [(MC '0')..(MC '7')] 116 | base = listArray ix blanks 117 | 118 | -- fred = putStrLn $ show2DArray $ mkDebugPath 21 119 | -- bar = runReader mkRawPath 6 \\ mask 120 | -- where 121 | -- mask = [(x,2) | x <- [0..5]] 122 | 123 | -- Create the coordinates, in order, where modules should 124 | -- be placed in a matrix. The path excludes function 125 | -- patterns so a bitstream can be zipped one to one to the 126 | -- coordinates into a matrix. The path flows from the most 127 | -- significant bit to the least 128 | mkPath :: ReaderQR Coords 129 | mkPath = mkRawPath `subtractPatterns` allFunctionPatterns 130 | 131 | -- Return a "raw" path in coordinates. This is the path that 132 | -- bits will follow according to the placement strategy in the spec. 133 | -- 134 | -- The path is created by intervolving up-row pairs and down-row pairs 135 | -- 136 | -- This creates a raw path. The real path can be obtained by simply 137 | -- subtracting functional patterns' coordinates. Note that 138 | -- the vertical timing pattern presents a special case because it will 139 | -- reverse the orientation. This is kind of difficult to explain in 140 | -- words but is apparent when you draw out the path on paper. 141 | mkRawPath :: ReaderQR Coords 142 | mkRawPath = do 143 | ver <- ask 144 | time <- natural 7 145 | 146 | let width = qrGetWidth ver 147 | upRowPair = concatMap (replicate 2) [0..(width-1)] 148 | downRowPair = reverse upRowPair 149 | 150 | mkCols = concat . concatMap (replicate width) . chunksOf 2 151 | mkRows = concat . cycle 152 | 153 | -- rows and cols "before" (to the right of) the vert timing pattern 154 | cols1 = mkCols [0..(time-1)] 155 | rows1 = mkRows [upRowPair, downRowPair] 156 | 157 | -- "after" 158 | cols2 = mkCols [(time+1)..(width-1)] 159 | rows2 = mkRows [downRowPair, upRowPair] 160 | 161 | return $ filter ((/=time) . fst) $ zip rows1 cols1 ++ zip rows2 cols2 162 | 163 | genTimingPattern :: Monad m => m [a] -> m [(a, Module)] 164 | genTimingPattern path = do 165 | p <- path 166 | return $ zip p (cycle [Dark, Light]) 167 | 168 | joinPatterns :: Applicative f => f [a] -> f [a] -> f [a] 169 | joinPatterns = (<*>) . ((++) <$>) 170 | 171 | fastDiff :: (Ord a) => [a] -> [a] -> [a] 172 | xs `fastDiff` ys = filter (flip S.notMember ys') xs 173 | where ys' = S.fromList ys 174 | 175 | subtractPatterns :: (Applicative f, Ord a) => f [a] -> f [a] -> f [a] 176 | subtractPatterns = (<*>) . (fastDiff <$>) 177 | 178 | (/+/) :: Applicative f => f [a] -> f [a] -> f [a] 179 | (/+/) = joinPatterns 180 | 181 | allFunctionPatterns :: ReaderQR Coords 182 | allFunctionPatterns = timingPatterns /+/ finderPatterns 183 | /+/ formatInfoRegions 184 | /+/ hardcodedDarkModule 185 | /+/ alignmentCoords 186 | /+/ versionInfoRegions 187 | 188 | -- Convert a top-left-origin position to a bottom-right-origin 189 | -- This is here so that we can input numbers according to the spec 190 | -- 191 | -- When the spec says the "6-th column", we can just say "natural 6" 192 | -- to get to the right position. 193 | -- 194 | -- i.e. the top-left-origin here is (1,1) 195 | natural :: Int -> ReaderQR Int 196 | natural n = do 197 | ver <- ask 198 | return $ qrGetWidth ver - n 199 | 200 | timingPatterns :: ReaderQR Coords 201 | timingPatterns = timingPatternHorizontal /+/ timingPatternVertical 202 | 203 | timingPatternHorizontal :: ReaderQR Coords 204 | timingPatternHorizontal = do 205 | ver <- ask 206 | row <- natural 7 207 | let width = qrGetWidth ver 208 | v = [(row,y) | y <- [0..(width-1)]] 209 | finder <- finderPatterns 210 | return $ v \\ finder 211 | 212 | timingPatternVertical :: ReaderQR Coords 213 | timingPatternVertical = map swap `fmap` timingPatternHorizontal 214 | 215 | versionInfoRegion' :: (Num a, Enum a) => (a -> Int -> b) -> ReaderQR [b] 216 | versionInfoRegion' f = do 217 | ver@(Version v) <- ask 218 | a <- natural 6 219 | let width = qrGetWidth ver 220 | rows = cycle [8..10] 221 | cols = concatMap (replicate 3) [a..width-1] 222 | return $ do 223 | guard $ v >= 7 224 | zipWith f rows cols 225 | 226 | versionInfoRegionBottomLeft :: (Num a, Enum a) => ReaderQR [(a, Int)] 227 | versionInfoRegionBottomLeft = versionInfoRegion' (,) 228 | 229 | versionInfoRegionTopRight :: (Num a, Enum a) => ReaderQR [(Int, a)] 230 | versionInfoRegionTopRight = versionInfoRegion' $ flip (,) 231 | 232 | versionInfoRegions :: ReaderQR [(Int, Int)] 233 | versionInfoRegions = versionInfoRegionBottomLeft /+/ versionInfoRegionTopRight 234 | 235 | -- Figure 19 in spec 236 | hardcodedDarkModule :: Num t => ReaderQR [(t, Int)] 237 | hardcodedDarkModule = do 238 | col <- natural 9 239 | return [(7,col)] 240 | 241 | formatInfoRegions :: ReaderQR [(Int, Int)] 242 | formatInfoRegions = formatInfoRegionHorizontal /+/ formatInfoRegionVertical 243 | 244 | formatInfoRegionHorizontal :: ReaderQR [(Int, Int)] 245 | formatInfoRegionHorizontal = do 246 | ver <- ask 247 | row <- natural 9 248 | c' <- natural 8 249 | let width = qrGetWidth ver 250 | return $ reverse [(row,col) | col <- [0..7] ++ [c'] ++ [c'+2..width-1]] 251 | 252 | formatInfoRegionVertical :: ReaderQR [(Int, Int)] 253 | formatInfoRegionVertical = do 254 | col <- natural 9 255 | 256 | let a = 0 257 | b = 6 258 | c <- natural 9 259 | d <- natural 8 260 | e <- natural 6 261 | f <- natural 1 262 | 263 | return [(row,col) | row <- [a..b] ++ [c..d] ++ [e..f]] 264 | 265 | finderPatterns :: ReaderQR [(Int, Int)] 266 | finderPatterns = finderPatternTopLeft /+/ finderPatternBottomLeft /+/ finderPatternTopRight 267 | 268 | -- Includes separators 269 | finderPatternTopLeft :: ReaderQR Coords 270 | finderPatternTopLeft = do 271 | ver <- ask 272 | r' <- natural 8 273 | let width = qrGetWidth ver 274 | return [(row,col) | let vals = [r'..(width-1)], row <- vals, col <- vals] 275 | 276 | finderPatternTopRight :: ReaderQR Coords 277 | finderPatternTopRight = do 278 | ver <- ask 279 | r' <- natural 8 280 | let width = qrGetWidth ver 281 | return [(row,col) | row <- [r'..width-1], col <- [0..7]] 282 | 283 | finderPatternBottomLeft :: ReaderQR Coords 284 | finderPatternBottomLeft = do 285 | ver <- ask 286 | let width = qrGetWidth ver 287 | c' <- natural 8 288 | return [(row,col) | row <- [0..7], col <- [c'..width-1]] 289 | 290 | -- This assumes a bottom-left origin, right to 291 | -- left bottom to top path 292 | genFinderPattern :: Monad m => Modules -> Modules -> Modules -> Modules -> m [a] -> m [(a, Module)] 293 | genFinderPattern prepend append lpadCol rpadCol path = do 294 | p <- path 295 | -- Add the separator to the raw finder pattern so 296 | -- that it matches exactly with the path given 297 | let pat = prepend ++ rawFinderPattern ++ append 298 | return $ zip p pat 299 | where 300 | rawFinderPattern = r1 ++ r2 ++ r3 ++ r3 ++ r3 ++ r2 ++ r1 301 | r1 = rpadCol ++ replicate 7 Dark ++ lpadCol 302 | r2 = rpadCol ++ [Dark, Light, Light, Light, Light, Light, Dark] ++ lpadCol 303 | r3 = rpadCol ++ [Dark, Light, Dark, Dark, Dark, Light, Dark] ++ lpadCol 304 | 305 | emptyFinderPatternRow :: Modules 306 | emptyFinderPatternRow = replicate 8 Light 307 | 308 | genFinderPatternTopLeft :: Monad m => m [a] -> m [(a, Module)] 309 | genFinderPatternTopLeft = genFinderPattern emptyFinderPatternRow [] [] [Light] 310 | 311 | genFinderPatternTopRight :: Monad m => m [a] -> m [(a, Module)] 312 | genFinderPatternTopRight = genFinderPattern emptyFinderPatternRow [] [Light] [] 313 | 314 | genFinderPatternBottomLeft :: Monad m => m [a] -> m [(a, Module)] 315 | genFinderPatternBottomLeft = genFinderPattern [] emptyFinderPatternRow [] [Light] 316 | 317 | genAlignmentPatterns :: [a] -> [(a, Module)] 318 | genAlignmentPatterns = flip zip (cycle patternMods) 319 | where 320 | patternMods = [ Dark, Dark, Dark, Dark, Dark 321 | , Dark, Light, Light, Light, Dark 322 | , Dark, Light, Dark, Light, Dark 323 | , Dark, Light, Light, Light, Dark 324 | , Dark, Dark, Dark, Dark, Dark 325 | ] 326 | 327 | overlapsFinder :: (Int,Int) -> ReaderQR Bool 328 | overlapsFinder (r,c) = do 329 | a <- natural 8 330 | return $ (r >= a && c >= a) || (r <= 8 && c >= a) || (r >= a && c <= 8) 331 | 332 | alignmentCoords :: MonadReader Version m => m [(Int, Int)] 333 | alignmentCoords = do 334 | ver <- ask 335 | let centers = qrAlignmentCenters ver 336 | validCenters = [(x,y) | x <- centers, y <- centers, let inFinder = runReader (overlapsFinder (x,y)) ver, not inFinder] 337 | 338 | mkPat (r,c) = [(r',c') | c' <- [c-2..c+2], r' <- [r-2..r+2]] 339 | 340 | pats = concatMap mkPat validCenters 341 | return pats 342 | -------------------------------------------------------------------------------- /Codec/Binary/QRCode/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK hide #-} 2 | module Codec.Binary.QRCode.Spec where 3 | 4 | import Data.Maybe 5 | 6 | import Codec.Binary.QRCode.GaloisField 7 | 8 | data Mode = Numeric -- ^ @0123456789@ 9 | 10 | -- | @0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ $%*+-.:.@ 11 | -- 12 | -- Input alphabets are automatically converted to upper case. 13 | | Alphanumeric 14 | | EightBit 15 | | Kanji 16 | deriving (Show, Eq) 17 | 18 | newtype Version = Version Int deriving (Show, Eq) 19 | data ErrorLevel = L -- ^ Error recovery up to 7%. 20 | | M -- ^ Error recovery up to 15%. 21 | | Q -- ^ Error recovery up to 25%. 22 | | H -- ^ Error recovery up to 30%. 23 | deriving (Show, Eq) 24 | data Info = Info 25 | { qrVersion :: Int 26 | , qrNumModulesPerSide :: Int 27 | , qrNumFunctionPatternModules :: Int 28 | , qrNumFormatAndVersionInfoModules :: Int 29 | , qrNumDataModules :: Int 30 | , qrDataCapacity :: Int 31 | , qrRemainderBits :: Int 32 | } deriving (Eq, Show) 33 | 34 | qrGetWidth :: Version -> Int 35 | qrGetWidth = qrNumModulesPerSide . qrGetInfo 36 | 37 | qrFormatInfoMask :: Int 38 | qrFormatInfoMask = readBin "101010000010010" 39 | 40 | qrFormatInfoGenPoly :: GFPolynomial 41 | qrFormatInfoGenPoly = mkPolynomial [1,0,1,0,0,1,1,0,1,1,1] 42 | 43 | qrVersionInfoGenPoly :: GFPolynomial 44 | qrVersionInfoGenPoly = mkPolynomial [1,1,1,1,1,0,0,1,0,0,1,0,1] 45 | 46 | qrErrorLevelIndicators :: ErrorLevel -> String 47 | qrErrorLevelIndicators L = "01" 48 | qrErrorLevelIndicators M = "00" 49 | qrErrorLevelIndicators Q = "11" 50 | qrErrorLevelIndicators H = "10" 51 | 52 | qrAlignmentCenters :: Version -> [Int] 53 | qrAlignmentCenters = fromJust . flip lookup table 54 | where 55 | table = 56 | [ ( Version 1, [] ) 57 | , ( Version 2, [6,18] ) 58 | , ( Version 3, [6,22] ) 59 | , ( Version 4, [6,26] ) 60 | , ( Version 5, [6,30] ) 61 | , ( Version 6, [6,34] ) 62 | , ( Version 7, [6,22,38] ) 63 | , ( Version 8, [6,24,42] ) 64 | , ( Version 9, [6,26,46] ) 65 | , ( Version 10, [6,28,50] ) 66 | , ( Version 11, [6,30,54] ) 67 | , ( Version 12, [6,32,58] ) 68 | , ( Version 13, [6,34,62] ) 69 | , ( Version 14, [6,26,46,66] ) 70 | , ( Version 15, [6,26,48,70] ) 71 | , ( Version 16, [6,26,50,74] ) 72 | , ( Version 17, [6,30,54,78] ) 73 | , ( Version 18, [6,30,56,82] ) 74 | , ( Version 19, [6,30,58,86] ) 75 | , ( Version 20, [6,34,62,90] ) 76 | , ( Version 21, [6,28,50,72,94] ) 77 | , ( Version 22, [6,26,50,74,98] ) 78 | , ( Version 23, [6,30,54,78,102] ) 79 | , ( Version 24, [6,28,54,80,106] ) 80 | , ( Version 25, [6,32,58,84,110] ) 81 | , ( Version 26, [6,30,58,86,114] ) 82 | , ( Version 27, [6,34,62,90,118] ) 83 | , ( Version 28, [6,26,50,74,98,122] ) 84 | , ( Version 29, [6,30,54,78,102,126] ) 85 | , ( Version 30, [6,26,52,78,104,130] ) 86 | , ( Version 31, [6,30,56,82,108,134] ) 87 | , ( Version 32, [6,34,60,86,112,138] ) 88 | , ( Version 33, [6,30,58,86,114,142] ) 89 | , ( Version 34, [6,34,62,90,118,146] ) 90 | , ( Version 35, [6,30,54,78,102,126,150] ) 91 | , ( Version 36, [6,24,50,76,102,128,154] ) 92 | , ( Version 37, [6,28,54,80,106,132,158] ) 93 | , ( Version 38, [6,32,58,84,110,136,162] ) 94 | , ( Version 39, [6,26,54,82,110,138,166] ) 95 | , ( Version 40, [6,30,58,86,114,142,170] ) 96 | ] 97 | 98 | 99 | qrGetInfo :: Version -> Info 100 | qrGetInfo = fromJust . flip lookup table 101 | where table = 102 | [ ( Version 1, Info 1 21 202 31 208 26 0 ) 103 | , ( Version 2, Info 2 25 235 31 359 44 7 ) 104 | , ( Version 3, Info 3 29 243 31 567 70 7 ) 105 | , ( Version 4, Info 4 33 251 31 807 100 7 ) 106 | , ( Version 5, Info 5 37 259 31 1079 134 7 ) 107 | , ( Version 6, Info 6 41 267 31 1383 172 7 ) 108 | , ( Version 7, Info 7 45 390 67 1568 196 0 ) 109 | , ( Version 8, Info 8 49 398 67 1936 242 0 ) 110 | , ( Version 9, Info 9 53 406 67 2336 292 0 ) 111 | , ( Version 10, Info 10 57 414 67 2768 346 0 ) 112 | , ( Version 11, Info 11 61 422 67 3232 404 0 ) 113 | , ( Version 12, Info 12 65 430 67 3728 466 0 ) 114 | , ( Version 13, Info 13 69 438 67 4256 532 0 ) 115 | , ( Version 14, Info 14 73 611 67 4651 581 3 ) 116 | , ( Version 15, Info 15 77 619 67 5243 655 3 ) 117 | , ( Version 16, Info 16 81 627 67 5867 733 3 ) 118 | , ( Version 17, Info 17 85 635 67 6523 815 3 ) 119 | , ( Version 18, Info 18 89 643 67 7211 901 3 ) 120 | , ( Version 19, Info 19 93 651 67 7931 991 3 ) 121 | , ( Version 20, Info 20 97 659 67 8683 1085 3 ) 122 | , ( Version 21, Info 21 101 882 67 9252 1156 4 ) 123 | , ( Version 22, Info 22 105 890 67 10068 1258 4 ) 124 | , ( Version 23, Info 23 109 898 67 10916 1364 4 ) 125 | , ( Version 24, Info 24 113 906 67 11796 1474 4 ) 126 | , ( Version 25, Info 25 117 914 67 12708 1588 4 ) 127 | , ( Version 26, Info 26 121 922 67 13652 1706 4 ) 128 | , ( Version 27, Info 27 125 930 67 14628 1828 4 ) 129 | , ( Version 28, Info 28 129 1203 67 15371 1921 3 ) 130 | , ( Version 29, Info 29 133 1211 67 16411 2051 3 ) 131 | , ( Version 30, Info 30 137 1219 67 17483 2185 3 ) 132 | , ( Version 31, Info 31 141 1227 67 18587 2323 3 ) 133 | , ( Version 32, Info 32 145 1235 67 19723 2465 3 ) 134 | , ( Version 33, Info 33 149 1243 67 20891 2611 3 ) 135 | , ( Version 34, Info 34 153 1251 67 22091 2761 3 ) 136 | , ( Version 35, Info 35 157 1574 67 23008 2876 0 ) 137 | , ( Version 36, Info 36 161 1582 67 24272 3034 0 ) 138 | , ( Version 37, Info 37 165 1590 67 25568 3196 0 ) 139 | , ( Version 38, Info 38 169 1598 67 26896 3362 0 ) 140 | , ( Version 39, Info 39 173 1606 67 28256 3532 0 ) 141 | , ( Version 40, Info 40 177 1614 67 29648 3706 0 ) 142 | ] 143 | 144 | mkVersion :: Int -> Version 145 | mkVersion = Version 146 | 147 | qrLengthsOfCCI :: [(Mode, Int)] 148 | qrLengthsOfCCI = zip (cycle [Numeric,Alphanumeric,EightBit,Kanji]) table 149 | where 150 | table = 151 | [ 10, 9, 8, 8 -- version 1 to 9 152 | , 12, 11, 16, 10 -- version 1 to 9 153 | , 14, 13, 16, 12 -- version 1 to 9 154 | ] 155 | 156 | qrLengthOfCCI :: Version -> Mode -> Int 157 | qrLengthOfCCI (Version ver) mode 158 | | ver >= 1 && ver <= 9 = go 0 159 | | ver >= 10 && ver <= 26 = go 1 160 | | ver >= 27 && ver <= 40 = go 2 161 | | otherwise = error $ "Invalid Version " ++ show ver 162 | where go n = fromJust $ lookup mode (drop (n*4) qrLengthsOfCCI) 163 | 164 | qrMatchTable :: Int -> ErrorLevel -> [a] -> a 165 | qrMatchTable ver err table = table !! ((ver-1) * 4 + m2i err) 166 | where 167 | m2i L = 0 168 | m2i M = 1 169 | m2i Q = 2 170 | m2i H = 3 171 | 172 | qrDCWSizes :: Num a => Int -> ErrorLevel -> [a] 173 | qrDCWSizes ver err = qrMatchTable ver err table 174 | where 175 | table = 176 | [ [19], [16], [13], [9] -- 1L, 1M, 1Q, 1H 177 | , [34], [28], [22], [16] 178 | , [55], [44], [17,17], [13,13] 179 | , [80], [32,32], [24,24], [9,9,9,9] 180 | , [108], [43,43], [15,15,16,16], [11,11,12,12] 181 | , [68,68], [27,27,27,27], [19,19,19,19], [15,15,15,15] 182 | , [78,78], [31,31,31,31], [14,14,15,15,15,15], [13,13,13,13,14] 183 | , [97,97], [38,38,39,39], [18,18,18,18,19,19], [14,14,14,14,15,15] 184 | , [116,116], [36,36,36,37,37], [16,16,16,16,17,17,17,17], [12,12,12,12,13,13,13,13] 185 | , [68,68,69,69], [43,43,43,43,44], [19,19,19,19,19,19,20,20], [15,15,15,15,15,15,16,16] 186 | , [81,81,81,81], [50,51,51,51,51], [22,22,22,22,23,23,23,23], [12,12,12,13,13,13,13,13,13,13,13] 187 | , [92,92,93,93], [36,36,36,36,36,36,37,37], [20,20,20,20,21,21,21,21,21,21], [14,14,14,14,14,14,14,15,15,15,15] 188 | , [107,107,107,107], [37,37,37,37,37,37,37,37,38], [20,20,20,20,20,20,20,20,21,21,21,21], [11,11,11,11,11,11,11,11,11,11,11,11,12,12,12,12] 189 | , [115,115,115,116], [40,40,40,40,41,41,41,41,41], [16,16,16,16,16,16,16,16,16,16,16,17,17,17,17,17], [12,12,12,12,12,12,12,12,12,12,12,13,13,13,13,13] 190 | , [87,87,87,87,87,88], [41,41,41,41,41,42,42,42,42,42], [24,24,24,24,24,25,25,25,25,25,25,25], [12,12,12,12,12,12,12,12,12,12,12,13,13,13,13,13,13,13] 191 | , [98,98,98,98,98,99], [45,45,45,45,45,45,45,46,46,46], [19,19,19,19,19,19,19,19,19,19,19,19,19,19,19,20,20], [15,15,15,16,16,16,16,16,16,16,16,16,16,16,16,16] 192 | , [107,108,108,108,108,108], [46,46,46,46,46,46,46,46,46,46,47], [22,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23], [14,14,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15] 193 | , [120,120,120,120,120,121], [43,43,43,43,43,43,43,43,43,44,44,44,44], [22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,23], [14,14,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15] 194 | , [113,113,113,114,114,114,114], [44,44,44,45,45,45,45,45,45,45,45,45,45,45], [21,21,21,21,21,21,21,21,21,21,21,21,21,21,21,21,21,22,22,22,22], [13,13,13,13,13,13,13,13,13,14,14,14,14,14,14,14,14,14,14,14,14,14,14,14,14] 195 | , [107,107,107,108,108,108,108,108], [41,41,41,42,42,42,42,42,42,42,42,42,42,42,42,42], [24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,25,25,25,25,25], [15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,16,16,16,16,16,16,16,16,16,16] 196 | , [116,116,116,116,117,117,117,117], [42,42,42,42,42,42,42,42,42,42,42,42,42,42,42,42,42], [22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,23,23,23,23,23,23], [16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,17,17,17,17,17,17] 197 | , [111,111,112,112,112,112,112,112,112], [46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46], [24,24,24,24,24,24,24,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25], [13,13,13,13,13,13,13,13,13,13,13,13,13,13,13,13,13,13,13,13,13,13,13,13,13,13,13,13,13,13,13,13,13,13] 198 | , [121,121,121,121,122,122,122,122,122], [47,47,47,47,48,48,48,48,48,48,48,48,48,48,48,48,48,48], [24,24,24,24,24,24,24,24,24,24,24,25,25,25,25,25,25,25,25,25,25,25,25,25,25], [15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,16,16,16,16,16,16,16,16,16,16,16,16,16,16] 199 | , [117,117,117,117,117,117,118,118,118,118], [45,45,45,45,45,45,46,46,46,46,46,46,46,46,46,46,46,46,46,46], [24,24,24,24,24,24,24,24,24,24,24,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25], [16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,17,17] 200 | , [106,106,106,106,106,106,106,106,107,107,107,107], [47,47,47,47,47,47,47,47,48,48,48,48,48,48,48,48,48,48,48,48,48], [24,24,24,24,24,24,24,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25], [15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,16,16,16,16,16,16,16,16,16,16,16,16,16] 201 | , [114,114,114,114,114,114,114,114,114,114,115,115], [46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,47,47,47,47], [22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,23,23,23,23,23,23], [16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,17,17,17,17] 202 | , [122,122,122,122,122,122,122,122,123,123,123,123], [45,45,45,45,45,45,45,45,45,45,45,45,45,45,45,45,45,45,45,45,45,45,46,46,46], [23,23,23,23,23,23,23,23,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24], [15,15,15,15,15,15,15,15,15,15,15,15,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16] 203 | , [117,117,117,118,118,118,118,118,118,118,118,118,118], [45,45,45,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46], [24,24,24,24,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25], [15,15,15,15,15,15,15,15,15,15,15,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16] 204 | , [116,116,116,116,116,116,116,117,117,117,117,117,117,117], [45,45,45,45,45,45,45,45,45,45,45,45,45,45,45,45,45,45,45,45,45,46,46,46,46,46,46,46], [23,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24], [15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16] 205 | , [115,115,115,115,115,116,116,116,116,116,116,116,116,116,116], [47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,48,48,48,48,48,48,48,48,48,48], [24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25], [15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16] 206 | , [115,115,115,115,115,115,115,115,115,115,115,115,115,116,116,116], [46,46,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47], [24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,25], [15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16] 207 | , [115,115,115,115,115,115,115,115,115,115,115,115,115,115,115,115,115], [46,46,46,46,46,46,46,46,46,46,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47], [24,24,24,24,24,24,24,24,24,24,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25], [15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16] 208 | , [115,115,115,115,115,115,115,115,115,115,115,115,115,115,115,115,115,116], [46,46,46,46,46,46,46,46,46,46,46,46,46,46,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47], [24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25], [15,15,15,15,15,15,15,15,15,15,15,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16] 209 | , [115,115,115,115,115,115,115,115,115,115,115,115,115,116,116,116,116,116,116], [46,46,46,46,46,46,46,46,46,46,46,46,46,46,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47], [24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,25,25,25,25,25,25,25], [16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,17] 210 | , [121,121,121,121,121,121,121,121,121,121,121,121,122,122,122,122,122,122,122], [47,47,47,47,47,47,47,47,47,47,47,47,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48], [24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,25,25,25,25,25,25,25,25,25,25,25,25,25,25], [15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16] 211 | , [121,121,121,121,121,121,122,122,122,122,122,122,122,122,122,122,122,122,122,122], [47,47,47,47,47,47,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48], [24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,25,25,25,25,25,25,25,25,25,25], [15,15,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16] 212 | , [122,122,122,122,122,122,122,122,122,122,122,122,122,122,122,122,122,123,123,123,123], [46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,46,47,47,47,47,47,47,47,47,47,47,47,47,47,47], [24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,25,25,25,25,25,25,25,25,25,25], [15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16] 213 | , [122,122,122,122,123,123,123,123,123,123,123,123,123,123,123,123,123,123,123,123,123,123], [46,46,46,46,46,46,46,46,46,46,46,46,46,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47], [24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,25,25,25,25,25,25,25,25,25,25,25,25,25,25], [15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16] 214 | , [117,117,117,117,117,117,117,117,117,117,117,117,117,117,117,117,117,117,117,117,118,118,118,118], [47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,48,48,48,48,48,48,48], [24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25], [15,15,15,15,15,15,15,15,15,15,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16] 215 | , [118,118,118,118,118,118,118,118,118,118,118,118,118,118,118,118,118,118,118,119,119,119,119,119,119], [47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,47,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48], [24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25], [15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16] 216 | ] 217 | 218 | 219 | qrNumErrorCodewordsPerBlock :: Num a => Int -> ErrorLevel -> a 220 | qrNumErrorCodewordsPerBlock ver err = qrMatchTable ver err table 221 | where table = 222 | [ 7, 10, 13, 17 -- 1M, 1M, 1Q, 1H 223 | , 10, 16, 22, 28 224 | , 15, 26, 18, 22 225 | , 20, 18, 26, 16 226 | , 26, 24, 18, 22 227 | , 18, 16, 24, 28 228 | , 20, 18, 18, 26 229 | , 24, 22, 22, 26 230 | , 30, 22, 20, 24 231 | , 18, 26, 24, 28 232 | , 20, 30, 28, 24 233 | , 24, 22, 26, 28 234 | , 26, 22, 24, 22 235 | , 30, 24, 20, 24 236 | , 22, 24, 30, 24 237 | , 24, 28, 24, 30 238 | , 28, 28, 28, 28 239 | , 30, 26, 28, 28 240 | , 28, 26, 26, 26 241 | , 28, 26, 30, 28 242 | , 28, 26, 28, 30 243 | , 28, 28, 30, 24 244 | , 30, 28, 30, 30 245 | , 30, 28, 30, 30 246 | , 26, 28, 30, 30 247 | , 28, 28, 28, 30 248 | , 30, 28, 30, 30 249 | , 30, 28, 30, 30 250 | , 30, 28, 30, 30 251 | , 30, 28, 30, 30 252 | , 30, 28, 30, 30 253 | , 30, 28, 30, 30 254 | , 30, 28, 30, 30 255 | , 30, 28, 30, 30 256 | , 30, 28, 30, 30 257 | , 30, 28, 30, 30 258 | , 30, 28, 30, 30 259 | , 30, 28, 30, 30 260 | , 30, 28, 30, 30 261 | , 30, 28, 30, 30 262 | ] 263 | 264 | qrNumDataBits :: Num a => Int -> ErrorLevel -> a 265 | qrNumDataBits ver mode = qrMatchTable ver mode table 266 | where table = 267 | [ 152, 128, 104, 72 268 | , 272, 224, 176, 128 269 | , 440, 352, 272, 208 270 | , 640, 512, 384, 288 271 | , 864, 688, 496, 368 272 | , 1088, 864, 608, 480 273 | , 1248, 992, 704, 528 274 | , 1552, 1232, 880, 688 275 | , 1856, 1456, 1056, 800 276 | , 2192, 1728, 1232, 976 277 | , 2592, 2032, 1440, 1120 278 | , 2960, 2320, 1648, 1264 279 | , 3424, 2672, 1952, 1440 280 | , 3688, 2920, 2088, 1576 281 | , 4184, 3320, 2360, 1784 282 | , 4712, 3624, 2600, 2024 283 | , 5176, 4056, 2936, 2264 284 | , 5768, 4504, 3176, 2504 285 | , 6360, 5016, 3560, 2728 286 | , 6888, 5352, 3880, 3080 287 | , 7456, 5712, 4096, 3248 288 | , 8048, 6256, 4544, 3536 289 | , 8752, 6880, 4912, 3712 290 | , 9392, 7312, 5312, 4112 291 | , 10208, 8000, 5744, 4304 292 | , 10960, 8496, 6032, 4768 293 | , 11744, 9024, 6464, 5024 294 | , 12248, 9544, 6968, 5288 295 | , 13048, 10136, 7288, 5608 296 | , 13880, 10984, 7880, 5960 297 | , 14744, 11640, 8264, 6344 298 | , 15640, 12328, 8920, 6760 299 | , 16568, 13048, 9368, 7208 300 | , 17528, 13800, 9848, 7688 301 | , 18448, 14496, 10288, 7888 302 | , 19472, 15312, 10832, 8432 303 | , 20528, 15936, 11408, 8768 304 | , 21616, 16816, 12016, 9136 305 | , 22496, 17728, 12656, 9776 306 | , 23648, 18672, 13328, 10208 307 | ] 308 | 309 | qrGenPoly :: Int -> [Int] 310 | qrGenPoly = map gfALog . qrGenPolyRaw 311 | 312 | -- Decreasing degree of x 313 | -- See ISO/IEC 2000 -- Annex A Error detection and correction generator polynomials 314 | qrGenPolyRaw :: Int -> [Int] 315 | qrGenPolyRaw 7 = [0,87,229,146,149,238,102,21] -- (x^7) + (a^87)(x^6) + (a^146)(x^4) + ... + (a^21) 316 | qrGenPolyRaw 10 = [0,251,67,46,61,118,70,64,94,32,45] 317 | qrGenPolyRaw 13 = [0,74,152,176,100,86,100,106,104,130,218,206,140,78] 318 | qrGenPolyRaw 15 = [0,8,183,61,91,202,37,51,58,58,237,140,124,5,99,105] 319 | qrGenPolyRaw 16 = [0,120,104,107,109,102,161,76,3,91,191,147,169,182,194,225,120] 320 | qrGenPolyRaw 17 = [0,43,139,206,78,43,239,123,206,214,147,24,99,150,39,243,163,136] 321 | qrGenPolyRaw 18 = [0,215,234,158,94,184,97,118,170,79,187,152,148,252,179,5,98,96,153] 322 | qrGenPolyRaw 20 = [0,17,60,79,50,61,163,26,187,202,180,221,225,83,239,156,164,212,212,188,190] 323 | qrGenPolyRaw 22 = [0,210,171,247,242,93,230,14,109,221,53,200,74,8,172,98,80,219,134,160,105,165,231] 324 | qrGenPolyRaw 24 = [0,229,121,135,48,211,117,251,126,159,180,169,152,192,226,228,218,111,0,117,232,87,96,227,21] 325 | qrGenPolyRaw 26 = [0,173,125,158,2,103,182,118,17,145,201,111,28,165,53,161,21,245,142,13,102,48,227,153,145,218,70] 326 | qrGenPolyRaw 28 = [0,168,223,200,104,224,234,108,180,110,190,195,147,205,27,232,201,21,43,245,87,42,195,212,119,242,37,9,123] 327 | qrGenPolyRaw 30 = [0,41,173,145,152,216,31,179,182,50,48,110,86,239,96,222,125,42,173,226,193,224,130,156,37,251,216,238,40,192,180] 328 | qrGenPolyRaw 32 = [0,10,6,106,190,249,167,4,67,209,138,138,32,242,123,89,27,120,185,80,156,38,69,171,60,28,222,80,52,254,185,220,241] 329 | qrGenPolyRaw 34 = [0,111,77,146,94,26,21,108,19,105,94,113,193,86,140,163,125,58,158,229,239,218,103,56,70,114,61,183,129,167,13,98,62,129,51] 330 | qrGenPolyRaw 36 = [0,200,183,98,16,172,31,246,234,60,152,115,0,167,152,113,248,238,107,18,63,218,37,87,210,105,177,120,74,121,196,117,251,113,233,30,120] 331 | qrGenPolyRaw 40 = [0,59,116,79,161,252,98,128,205,128,161,247,57,163,56,235,106,53,26,187,174,226,104,170,7,175,35,181,114,88,41,47,163,125,134,72,20,232,53,35,15] 332 | qrGenPolyRaw 42 = [0,250,103,221,230,25,18,137,231,0,3,58,242,221,191,110,84,230,8,188,106,96,147,15,131,139,34,101,223,39,101,213,199,237,254,201,123,171,162,194,117,50,96] 333 | qrGenPolyRaw 44 = [0,190,7,61,121,71,246,69,55,168,188,89,243,191,25,72,123,9,145,14,247,1,238,44,78,143,62,224,126,118,114,68,163,52,194,217,147,204,169,37,130,113,102,73,181] 334 | qrGenPolyRaw 46 = [0,112,94,88,112,253,224,202,115,187,99,89,5,54,113,129,44,58,16,135,216,169,211,36,1,4,96,60,241,73,104,234,8,249,245,119,174,52,25,157,224,43,202,223,19,82,15] 335 | qrGenPolyRaw 48 = [0,228,25,196,130,211,146,60,24,251,90,39,102,240,61,178,63,46,123,115,18,221,111,135,160,182,205,107,206,95,150,120,184,91,21,247,156,140,238,191,11,94,227,84,50,163,39,34,108] 336 | qrGenPolyRaw 50 = [0,232,125,157,161,164,9,118,46,209,99,203,193,35,3,209,111,195,242,203,225,46,13,32,160,126,209,130,160,242,215,242,75,77,42,189,32,113,65,124,69,228,114,235,175,124,170,215,232,133,205] 337 | qrGenPolyRaw 52 = [0,116,50,86,186,50,220,251,89,192,46,86,127,124,19,184,233,151,215,22,14,59,145,37,242,203,134,254,89,190,94,59,65,124,113,100,233,235,121,22,76,86,97,39,242,200,220,101,33,239,254,116,51] 338 | qrGenPolyRaw 54 = [0,183,26,201,87,210,221,113,21,46,65,45,50,238,184,249,225,102,58,209,218,109,165,26,95,184,192,52,245,35,254,238,175,172,79,123,25,122,43,120,108,215,80,128,201,235,8,153,59,101,31,198,76,31,156] 339 | qrGenPolyRaw 56 = [0,106,120,107,157,164,216,112,116,2,91,248,163,36,201,202,229,6,144,254,155,135,208,170,209,12,139,127,142,182,249,177,174,190,28,10,85,239,184,101,124,152,206,96,23,163,61,27,196,247,151,154,202,207,20,61,10] 340 | qrGenPolyRaw 58 = [0,82,116,26,247,66,27,62,107,252,182,200,185,235,55,251,242,210,144,154,237,176,141,192,248,152,249,206,85,253,142,65,165,125,23,24,30,122,240,214,6,129,218,29,145,127,134,206,245,117,29,41,63,159,142,233,125,148,123] 341 | qrGenPolyRaw 60 = [0,107,140,26,12,9,141,243,197,226,197,219,45,211,101,219,120,28,181,127,6,100,247,2,205,198,57,115,219,101,109,160,82,37,38,238,49,160,209,121,86,11,124,30,181,84,25,194,87,65,102,190,220,70,27,209,16,89,7,33,240] 342 | qrGenPolyRaw 62 = [0,65,202,113,98,71,223,248,118,214,94,0,122,37,23,2,228,58,121,7,105,135,78,243,118,70,76,223,89,72,50,70,111,194,17,212,126,181,35,221,117,235,11,229,149,147,123,213,40,115,6,200,100,26,246,182,218,127,215,36,186,110,106] 343 | qrGenPolyRaw 64 = [0,45,51,175,9,7,158,159,49,68,119,92,123,177,204,187,254,200,78,141,149,119,26,127,53,160,93,199,212,29,24,145,156,208,150,218,209,4,216,91,47,184,146,47,140,195,195,125,242,238,63,99,108,140,230,242,31,204,11,178,243,217,156,213,231] 344 | qrGenPolyRaw 66 = [0,5,118,222,180,136,136,162,51,46,117,13,215,81,17,139,247,197,171,95,173,65,137,178,68,111,95,101,41,72,214,169,197,95,7,44,154,77,111,236,40,121,143,63,87,80,253,240,126,217,77,34,232,106,50,168,82,76,146,67,106,171,25,32,93,45,105] 345 | qrGenPolyRaw 68 = [0,247,159,223,33,224,93,77,70,90,160,32,254,43,150,84,101,190,205,133,52,60,202,165,220,203,151,93,84,15,84,253,173,160,89,227,52,199,97,95,231,52,177,41,125,137,241,166,225,118,2,54,32,82,215,175,198,43,238,235,27,101,184,127,3,5,8,163,238] 346 | qrGenPolyRaw _ = error "Invalid number of codewords" 347 | --------------------------------------------------------------------------------