qr (empty) → 0.2.0.0
raw patch · 10 files changed
+1218/−0 lines, 10 filesdep +arraydep +basedep +cairosetup-changed
Dependencies added: array, base, cairo, gtk, optparse-applicative, qr, transformers, utf8-string
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- cqr/cqr.hs +224/−0
- qr.cabal +38/−0
- src/Data/QR/Encode.hs +81/−0
- src/Data/QR/Grouping.hs +205/−0
- src/Data/QR/Layout.hs +301/−0
- src/Data/QR/ReedSolomon.hs +80/−0
- src/Data/QR/Tables.hs +216/−0
- src/Data/QR/Types.hs +41/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2013, Paolo Capriotti++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Paolo Capriotti nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ cqr/cqr.hs view
@@ -0,0 +1,224 @@+{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}+module Main where++import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Control.Monad.Trans.Maybe+import qualified Data.Array as A+import Data.Foldable (Foldable, asum)+import Data.Maybe+import Data.Monoid ((<>))+import Data.Traversable (Traversable, traverse)+import Data.IORef+import qualified Graphics.Rendering.Cairo as Cairo+import Graphics.UI.Gtk hiding (Display, Target)+import Options.Applicative+import System.Exit+import System.IO++import Data.QR.Encode+import Data.QR.Layout+import Data.QR.Grouping+import Data.QR.Types++data Opts s = Opts+ { optVersion :: Maybe Version+ , optLevel :: Level+ , optMode :: Mode+ , optMDisplay :: Maybe Display+ , optOutput :: Maybe FilePath+ , optSize :: Maybe (Int, Int)+ , optSource :: s }+ deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable)++optDisplay :: Opts s -> Display+optDisplay args = case optMDisplay args of+ Just d -> d+ Nothing -> case optOutput args *> optSize args of+ Just _ -> Image+ Nothing -> Cairo++data Display = Cairo | Console | Image+ deriving (Eq, Ord, Read, Show)++data Source = Text String+ | File FilePath+ | StdIn+ deriving (Eq, Ord, Read, Show)++opts :: Parser (Opts Source)+opts = Opts+ <$> (optional . option auto)+ ( long "symversion"+ <> short 'V'+ <> metavar "NUMBER"+ <> help "Version of the QR code: 1 to 40 (default: auto)" )+ <*> option auto+ ( long "level"+ <> short 'l'+ <> metavar "LEVEL"+ <> help "Error correction: L, M, Q (default) or H"+ <> value Q )+ <*> option auto+ ( long "mode"+ <> short 'm'+ <> metavar "MODE"+ <> help "Encoding mode: Numeric, Alpha or Byte (default)"+ <> value Byte )+ <*> (optional . option displayReader)+ ( long "display"+ <> short 'd'+ <> metavar "[cairo|console|image]"+ <> help "Display mode" )+ <*> (optional . option str)+ ( long "output"+ <> short 'o'+ <> metavar "FILE"+ <> help "Output file (implies image display)" )+ <*> (optional . option sizeReader)+ ( long "size"+ <> short 's'+ <> metavar "WIDTH,HEIGHT"+ <> help (concat [ "Image width and height in pixels, "+ , "comma separated "+ , "(implies image display)" ]) )+ <*> src++displayReader :: ReadM Display+displayReader = eitherReader $ \s -> do+ case s of+ "cairo" -> return Cairo+ "console" -> return Console+ "image" -> return Image+ _ -> Left "Invalid display mode. Possible choices: cairo, console, image."++sizeReader :: ReadM (Int, Int)+sizeReader = eitherReader $ \s -> do+ case break (== ',') s of+ (x, ',':y) -> (,) <$> sread "width" x <*> sread "height" y+ _ -> Left "Invalid size."+ where+ sread w x = case reads x of+ [(v, "")] -> Right v+ _ -> Left ("Invalid " ++ w ++ ".")++fileSource :: FilePath -> Source+fileSource "-" = StdIn+fileSource s = File s++src :: Parser Source+src = asum+ [ option r ( long "file"+ <> short 'f'+ <> metavar "FILENAME"+ <> help ( "Filename containing the data to encode "+ ++ "(use '-' for standard input)" ) )+ , Text <$> argument str ( metavar "TEXT" )+ , pure StdIn ]+ where+ r = fmap fileSource str++extractText :: Source -> IO String+extractText (Text t) = pure t+extractText StdIn = getContents+extractText (File f) = readFile f++matrix :: Opts String -> Maybe Matrix+matrix (Opts mv l m _ _ _ txt) = do+ v <- mv <|> minimumVersion l m (length txt)+ return $ layout v l (message v l m txt)++main :: IO ()+main = do+ args <- execParser $ info (opts <**> helper)+ ( progDesc "Show a QR code" )+ targs <- traverse extractText args+ case matrix targs of+ Nothing -> hPutStrLn stderr "Message too large for a QR code"+ >> exitWith (ExitFailure 1)+ Just m -> runGUI args (optDisplay args) m++runGUI :: Opts s -> Display -> Matrix -> IO ()+runGUI _ Console m = do+ let (_, (xsize, ysize)) = A.bounds m+ let white = putStr "\ESC[47m \ESC[0m"+ let black = putStr "\ESC[40m \ESC[0m"+ replicateM_ (xsize + 3) white+ putChar '\n'+ forM_ [0 .. ysize] $ \y -> do+ white+ forM_ [0 .. xsize] $ \x -> do+ let c = m A.! (x, y)+ if c == Dark then black else white+ white+ putChar '\n'+ replicateM_ (xsize + 3) white+ putChar '\n'+runGUI _ Cairo m = do+ _ <- initGUI+ window <- windowNew++ _ <- window `on` exposeEvent $+ drawWindow window m+ _ <- handleResize window++ _ <- onDestroy window mainQuit+ widgetShowAll window+ mainGUI+runGUI args Image m = do+ let (w, h) = fromMaybe (300, 300) (optSize args)+ fmt = Cairo.FormatARGB32+ Cairo.withImageSurface fmt w h $ \surface -> do+ Cairo.renderWith surface (drawMatrix w h m)+ Cairo.surfaceWriteToPNG surface (fromMaybe "out.png" (optOutput args))++handleResize :: WindowClass w+ => w -> IO (ConnectId w)+handleResize window = do+ current <- windowGetSize window >>= newIORef+ (window `on` configureEvent) . fmap (const False) . runMaybeT $ do+ old_sz <- liftIO $ readIORef current+ sz <- lift eventSize+ guard $ sz /= old_sz+ liftIO $ do+ widgetQueueDraw window+ writeIORef current sz++drawMatrix :: Int -> Int -> Matrix -> Cairo.Render ()+drawMatrix wxi wyi m = do+ let (_, (xsize, ysize)) = A.bounds m+ multx = wxi `div` (xsize + 9)+ multy = wyi `div` (ysize + 9)+ mult = min multx multy+ offsetx = (wxi - mult * (xsize + 1)) `div` 2+ offsety = (wyi - mult * (ysize + 1)) `div` 2+ setColor Light = Cairo.setSourceRGB 1 1 1+ setColor Dark = Cairo.setSourceRGB 0 0 0+ setColor Reserved = Cairo.setSourceRGB 0.0 0.0 0.8+ setColor Empty = Cairo.setSourceRGB 0.8 0.8 0.8+ let drawTile md (x, y) = do+ Cairo.rectangle+ (fromIntegral (offsetx + x * mult))+ (fromIntegral (offsety + y * mult))+ (fromIntegral mult)+ (fromIntegral mult)+ setColor md+ Cairo.fill++ -- background+ setColor Light+ Cairo.rectangle 0 0 (fromIntegral wxi) (fromIntegral wyi)+ Cairo.fill++ Cairo.setLineWidth 0.1+ forM_ (A.assocs m) $ \(p, t) -> drawTile t p++drawWindow :: (MonadIO m, WidgetClass w)+ => w -> Matrix -> m Bool+drawWindow window m = liftIO $ do+ (wxi, wyi) <- liftIO $ widgetGetSize window+ cr <- widgetGetDrawWindow window+ renderWithDrawable cr (drawMatrix wxi wyi m)++ return True
+ qr.cabal view
@@ -0,0 +1,38 @@+name: qr+version: 0.2.0.0+synopsis: Pure Haskell QR encoder library and command line tool+license: BSD3+license-file: LICENSE+author: Paolo Capriotti+maintainer: p.capriotti@gmail.com+category: Data+build-type: Simple+cabal-version: >=1.10++library+ build-depends:+ base,+ array,+ utf8-string+ ghc-options: -Wall -O2+ hs-source-dirs: src+ exposed-modules:+ Data.QR.Encode,+ Data.QR.Grouping,+ Data.QR.Layout,+ Data.QR.ReedSolomon,+ Data.QR.Tables,+ Data.QR.Types+ default-language: Haskell2010++executable cqr+ main-is: cqr/cqr.hs+ default-language: Haskell2010+ build-depends:+ base < 5,+ array,+ gtk,+ cairo,+ transformers,+ optparse-applicative,+ qr
+ src/Data/QR/Encode.hs view
@@ -0,0 +1,81 @@+module Data.QR.Encode where++import qualified Codec.Binary.UTF8.String as UTF8+import Data.Char+import Data.Maybe+import Data.Word++import Data.QR.Tables+import Data.QR.Types++countLength :: Version -> Mode -> Int+countLength v = f c+ where+ c | v < 10 = 0 :: Int+ | v < 27 = 1+ | otherwise = 2+ f 0 Numeric = 10+ f 1 Numeric = 12+ f _ Numeric = 14+ f 0 Alpha = 9+ f 1 Alpha = 11+ f _ Alpha = 13+ f 0 Byte = 8+ f _ Byte = 16++count :: Version -> Mode -> Int -> [Bit]+count v m = toBinary (countLength v m)++mode :: Mode -> [Bit]+mode = toBinary 4 . go+ where+ go Numeric = 1 :: Int+ go Alpha = 2+ go Byte = 4++encodeData :: Mode -> String -> (Int, [Bit])+encodeData Numeric xs = (length xs, chunksOf 3 xs >>= encodeChunk)+ where+ encodeChunk c = case reads c of+ [(n, "")] | n >= 0 -> toBinary (bits (length c)) (n :: Int)+ _ -> []+ bits 1 = 4+ bits 2 = 7+ bits _ = 10+encodeData Alpha xs = (length xs, chunksOf 2 xs >>= encodeChunk)+ where+ encodeChunk [x] = toBinary 6 (value x)+ encodeChunk [x, y] = toBinary 11 (value x * 45 + value y)+ encodeChunk _ = []++ value ' ' = 36+ value '$' = 37+ value '%' = 38+ value '*' = 39+ value '+' = 40+ value '-' = 41+ value '.' = 42+ value '/' = 43+ value ':' = 44+ value x+ | isAlpha x = ord (toUpper x) - ord 'A' + 10+ | isDigit x = digitToInt x+ | otherwise = 0+encodeData Byte xs = (length binData, binData >>= toBinary 8)+ where+ binData = UTF8.encode xs++encode :: Version -> Level -> Mode -> String -> [Word8]+encode v l m xs = toWords $ take total $ base ++ pad8 ++ cycle padding+ where+ (size, encoded) = encodeData m xs+ base0 = mode m ++ count v m size ++ encoded+ base = take total $ base0 ++ replicate 4 Z+ total = dataBits v l+ pad8 = replicate ((-(length base)) `mod` 8) Z+ padding = [O,O,O,Z,O,O,Z,Z,Z,Z,Z,O,Z,Z,Z,O]++minimumVersion :: Level -> Mode -> Int -> Maybe Version+minimumVersion l m sz = fmap fst . listToMaybe . dropWhile ((< sz) . snd)+ . zip [1..] . map (capacity l m)+ $ [1 .. 40]
+ src/Data/QR/Grouping.hs view
@@ -0,0 +1,205 @@+module Data.QR.Grouping where++import Data.List+import Data.Word++import Data.QR.Types+import Data.QR.ReedSolomon+import Data.QR.Encode++data Grouping = Grouping+ { group1 :: Group+ , group2 :: Group+ , ecSize :: Int }+ deriving (Eq, Ord, Show, Read)++data Group = Group+ { gpBlocks :: Int+ , gpSize :: Int }+ deriving (Eq, Ord, Show, Read)++groupSize :: Group -> Int+groupSize (Group s b) = s * b++interleave :: [[a]] -> [a]+interleave = concat . transpose++message :: Version -> Level -> Mode -> String -> [Word8]+message v l m xs = fullMessage v l (encode v l m xs)++fullMessage :: Version -> Level -> [Word8] -> [Word8]+fullMessage v l ws = interleave blocks ++ interleave ec+ where+ gpng = grouping v l+ (part1, part2) = splitAt (groupSize (group1 gpng)) ws+ blocks = chunksOf (gpSize (group1 gpng)) part1+ ++ chunksOf (gpSize (group2 gpng)) part2+ ec = map (errorWords (ecSize gpng)) blocks++grouping :: Version -> Level -> Grouping+grouping v l = gps !! ((v - 1) * 4 + levelIndex l)+ where+ gp :: Int -> Int -> Int -> Int -> Int -> Grouping+ gp ec g1 b1 g2 b2 = Grouping (Group g1 b1) (Group g2 b2) ec++ gps =+ [ gp 7 1 19 0 0+ , gp 10 1 16 0 0+ , gp 13 1 13 0 0+ , gp 17 1 9 0 0+ , gp 10 1 34 0 0+ , gp 16 1 28 0 0+ , gp 22 1 22 0 0+ , gp 28 1 16 0 0+ , gp 15 1 55 0 0+ , gp 26 1 44 0 0+ , gp 18 2 17 0 0+ , gp 22 2 13 0 0+ , gp 20 1 80 0 0+ , gp 18 2 32 0 0+ , gp 26 2 24 0 0+ , gp 16 4 9 0 0+ , gp 26 1 108 0 0+ , gp 24 2 43 0 0+ , gp 18 2 15 2 16+ , gp 22 2 11 2 12+ , gp 18 2 68 0 0+ , gp 16 4 27 0 0+ , gp 24 4 19 0 0+ , gp 28 4 15 0 0+ , gp 20 2 78 0 0+ , gp 18 4 31 0 0+ , gp 18 2 14 4 15+ , gp 26 4 13 1 14+ , gp 24 2 97 0 0+ , gp 22 2 38 2 39+ , gp 22 4 18 2 19+ , gp 26 4 14 2 15+ , gp 30 2 116 0 0+ , gp 22 3 36 2 37+ , gp 20 4 16 4 17+ , gp 24 4 12 4 13+ , gp 18 2 68 2 69+ , gp 26 4 43 1 44+ , gp 24 6 19 2 20+ , gp 28 6 15 2 16+ , gp 20 4 81 0 0+ , gp 30 1 50 4 51+ , gp 28 4 22 4 23+ , gp 24 3 12 8 13+ , gp 24 2 92 2 93+ , gp 22 6 36 2 37+ , gp 26 4 20 6 21+ , gp 28 7 14 4 15+ , gp 26 4 107 0 0+ , gp 22 8 37 1 38+ , gp 24 8 20 4 21+ , gp 22 12 11 4 12+ , gp 30 3 115 1 116+ , gp 24 4 40 5 41+ , gp 20 11 16 5 17+ , gp 24 11 12 5 13+ , gp 22 5 87 1 88+ , gp 24 5 41 5 42+ , gp 30 5 24 7 25+ , gp 24 11 12 7 13+ , gp 24 5 98 1 99+ , gp 28 7 45 3 46+ , gp 24 15 19 2 20+ , gp 30 3 15 13 16+ , gp 28 1 107 5 108+ , gp 28 10 46 1 47+ , gp 28 1 22 15 23+ , gp 28 2 14 17 15+ , gp 30 5 120 1 121+ , gp 26 9 43 4 44+ , gp 28 17 22 1 23+ , gp 28 2 14 19 15+ , gp 28 3 113 4 114+ , gp 26 3 44 11 45+ , gp 26 17 21 4 22+ , gp 26 9 13 16 14+ , gp 28 3 107 5 108+ , gp 26 3 41 13 42+ , gp 30 15 24 5 25+ , gp 28 15 15 10 16+ , gp 28 4 116 4 117+ , gp 26 17 42 0 0+ , gp 28 17 22 6 23+ , gp 30 19 16 6 17+ , gp 28 2 111 7 112+ , gp 28 17 46 0 0+ , gp 30 7 24 16 25+ , gp 24 34 13 0 0+ , gp 30 4 121 5 122+ , gp 28 4 47 14 48+ , gp 30 11 24 14 25+ , gp 30 16 15 14 16+ , gp 30 6 117 4 118+ , gp 28 6 45 14 46+ , gp 30 11 24 16 25+ , gp 30 30 16 2 17+ , gp 26 8 106 4 107+ , gp 28 8 47 13 48+ , gp 30 7 24 22 25+ , gp 30 22 15 13 16+ , gp 28 10 114 2 115+ , gp 28 19 46 4 47+ , gp 28 28 22 6 23+ , gp 30 33 16 4 17+ , gp 30 8 122 4 123+ , gp 28 22 45 3 46+ , gp 30 8 23 26 24+ , gp 30 12 15 28 16+ , gp 30 3 117 10 118+ , gp 28 3 45 23 46+ , gp 30 4 24 31 25+ , gp 30 11 15 31 16+ , gp 30 7 116 7 117+ , gp 28 21 45 7 46+ , gp 30 1 23 37 24+ , gp 30 19 15 26 16+ , gp 30 5 115 10 116+ , gp 28 19 47 10 48+ , gp 30 15 24 25 25+ , gp 30 23 15 25 16+ , gp 30 13 115 3 116+ , gp 28 2 46 29 47+ , gp 30 42 24 1 25+ , gp 30 23 15 28 16+ , gp 30 17 115 0 0+ , gp 28 10 46 23 47+ , gp 30 10 24 35 25+ , gp 30 19 15 35 16+ , gp 30 17 115 1 116+ , gp 28 14 46 21 47+ , gp 30 29 24 19 25+ , gp 30 11 15 46 16+ , gp 30 13 115 6 116+ , gp 28 14 46 23 47+ , gp 30 44 24 7 25+ , gp 30 59 16 1 17+ , gp 30 12 121 7 122+ , gp 28 12 47 26 48+ , gp 30 39 24 14 25+ , gp 30 22 15 41 16+ , gp 30 6 121 14 122+ , gp 28 6 47 34 48+ , gp 30 46 24 10 25+ , gp 30 2 15 64 16+ , gp 30 17 122 4 123+ , gp 28 29 46 14 47+ , gp 30 49 24 10 25+ , gp 30 24 15 46 16+ , gp 30 4 122 18 123+ , gp 28 13 46 32 47+ , gp 30 48 24 14 25+ , gp 30 42 15 32 16+ , gp 30 20 117 4 118+ , gp 28 40 47 7 48+ , gp 30 43 24 22 25+ , gp 30 10 15 67 16+ , gp 30 19 118 6 119+ , gp 28 18 47 31 48+ , gp 30 34 24 34 25+ , gp 30 20 15 61 16 ]
+ src/Data/QR/Layout.hs view
@@ -0,0 +1,301 @@+module Data.QR.Layout where++import Data.Array+import Data.Bits+import Data.Function+import Data.List+import Data.Word++import Data.QR.Types++type Coord = (Int, Int)+data Module = Empty | Reserved | Light | Dark+ deriving (Eq, Ord, Read, Show, Enum)+type Matrix = Array Coord Module++size :: Version -> Int+size v = v * 4 + 17++bitToModule :: Bit -> Module+bitToModule Z = Light+bitToModule O = Dark++maskModule :: Int -> Coord -> Bool+maskModule 0 (x, y) = (x + y) `mod` 2 == 0+maskModule 1 (_, y) = y `mod` 2 == 0+maskModule 2 (x, _) = x `mod` 3 == 0+maskModule 3 (x, y) = (x + y) `mod` 3 == 0+maskModule 4 (x, y) = (x `div` 3 + y `div` 2) `mod` 2 == 0+maskModule 5 (x, y) = let z = x * y in z `mod` 2 + z `mod` 3 == 0+maskModule 6 (x, y) = let z = x * y in (z `mod` 2 + z `mod` 3) `mod` 2 == 0+maskModule 7 (x, y) = ((x + y) `mod` 2 + (x * y) `mod` 3) `mod` 2 == 0+maskModule n _ = error $ "maskModule: invalid mask " ++ show n++neighbours :: Int -> Coord -> [Coord]+neighbours k (x, y) = concat+ [ (,) <$> [x-k,x+k] <*> [y-k..y+k]+ , (,) <$> [x-k+1..x+k-1] <*> [y-k,y+k] ]++alignmentPatterns :: Version -> [(Coord, Module)]+alignmentPatterns v = centers >>= pattern+ where+ cs = alignment v+ sz = size v+ centers = filter valid ((,) <$> cs <*> cs)+ valid (x, y) = not $ or+ [ x < 10 && y < 10+ , x < 10 && y > sz - 11+ , x > sz - 11 && y < 10 ]+ pattern c = [(x, Dark) | x <- c : neighbours 2 c]+ ++ [(x, Light) | x <- neighbours 1 c]++finderPatterns :: Version -> [(Coord, Module)]+finderPatterns v = centers >>= pattern+ where+ sz = size v+ centers = [(3, 3), (sz - 4, 3), (3, sz - 4)]+ pattern c = [(x, Dark) | x <- c : neighbours 1 c ++ neighbours 3 c ]+ ++ [(x, Light) | x <- neighbours 2 c ++ neighbours 4 c+ , valid x ]+ valid (x, y) = x >= 0 && x < sz && y >= 0 && y < sz++timingPatterns :: Version -> [(Coord, Module)]+timingPatterns v = pattern ++ map swap pattern+ where+ sz = size v+ pattern = [((x, 6), col x) | x <- [8 .. sz - 9]]+ col x = if x `mod` 2 == 0 then Dark else Light+ swap ((x, y), t) = ((y, x), t)++darkModule :: Version -> [(Coord, Module)]+darkModule v = [((8, 4 * v + 9), Dark)]++reservedAreas :: Version -> [Coord]+reservedAreas v = (8,8)+ : [(8, y) | y <- [0 .. 5] ++ [7] ++ [sz - 7 .. sz - 1] ]+ ++ [(x, 8) | x <- [0 .. 5] ++ [7] ++ [sz - 8 .. sz - 1] ]+ ++ [c | v >= 7+ , x <- [sz - 11 .. sz - 9]+ , y <- [0 .. 5]+ , c <- sym x y ]+ where+ sz = size v+ sym x y = [(x, y), (y, x)]++reservedPatterns :: Version -> [(Coord, Module)]+reservedPatterns v = [(c, Reserved) | c <- reservedAreas v]++showModule :: Module -> Char+showModule Light = '-'+showModule Dark = '*'+showModule Empty = ' '+showModule Reserved = 'x'++showMatrix :: Matrix -> String+showMatrix m = unlines $ map row [0 .. h]+ where+ (_, (w, h)) = bounds m+ row y = map (\x -> tile x y) [0 .. w]+ tile x y = showModule $ m ! (x, y)++placement :: Matrix -> [Coord]+placement m = filter available cs+ where+ available c = m ! c == Empty+ (_, (_, n)) = bounds m+ line (x, r) =+ [ c | y <- if r then [n, n-1 .. 0] else [0 .. n]+ , c <- [(x, y), (x-1, y)] ]+ cols = zip ([n, n-2 .. 8] ++ [5, 3, 1])+ (cycle [True, False])+ cs = cols >>= line++placeBits :: Matrix -> [Word8] -> [(Coord, Module)]+placeBits m = placeWords (placement m)+ where+ bits :: Word8 -> [Module]+ bits w = map (\mask -> if w .&. mask == 0 then Light else Dark)+ (take 8 (iterate (`shiftR` 1) 0x80))++ placeWord :: [Coord] -> Word8 -> ([Coord], [(Coord, Module)])+ placeWord cs w = case splitAt 8 cs of+ (cs1, cs') -> (cs', zip cs1 (bits w))++ placeWords :: [Coord] -> [Word8] -> [(Coord, Module)]+ placeWords [] _ = []+ placeWords cs [] = zip cs (repeat Light)+ placeWords cs (w : ws') = case placeWord cs w of+ (cs', ms) -> ms ++ placeWords cs' ws'++mkMatrix :: Version -> [(Coord, Module)] -> Matrix+mkMatrix v = accumArray max Empty ((0, 0), (sz-1, sz-1))+ where+ sz = size v++baseMatrix :: Version -> Matrix+baseMatrix v = mkMatrix v $ concat+ [ finderPatterns v+ , alignmentPatterns v+ , timingPatterns v+ , darkModule v+ , reservedPatterns v ]++maskedMatrices :: Version -> [Word8] -> [Matrix]+maskedMatrices v ws = map (\i -> mat // allBits i) [0..7]+ where+ mat = baseMatrix v+ ms = placeBits mat ws+ maskedBits i = map (\(c, m) -> (c, if maskModule i c then invert m else m)) ms+ reservedBits = [(c, Light) | c <- reservedAreas v]+ allBits i = maskedBits i ++ reservedBits++ invert Light = Dark+ invert Dark = Light+ invert m = m++formatBits :: Level -> Int -> Matrix -> [(Coord, Module)]+formatBits l k m = zip cs1 info ++ zip cs2 info+ where+ (_, (n,_)) = bounds m+ cs1 = [(x, 8) | x <- [0,1,2,3,4,5,7,8]]+ ++ [(8, y) | y <- [7,5,4,3,2,1,0]]+ cs2 = [(8, y) | y <- [n, n-1 .. n-7]]+ ++ [(x, 8) | x <- [n-6, n-5 .. n]]++ info = map bitToModule $ formatInfo l k++versionBits :: Version -> Matrix -> [(Coord, Module)]+versionBits v m | v > 6 = zip cs1 info ++ zip cs2 info+ | otherwise = []+ where+ (_, (n,_)) = bounds m+ cs1 = [(x, y) | x <- [5,4,3,2,1,0]+ , y <- [n-8,n-9,n-10]]+ cs2 = [(x, y) | y <- [5,4,3,2,1,0]+ , x <- [n-8,n-9,n-10]]+ info = map bitToModule $ versionInfo v++layout :: Version -> Level -> [Word8] -> Matrix+layout v l ws = mat // (formatBits l k mat ++ versionBits v mat)+ where+ mats = zip [0..] (maskedMatrices v ws)+ (k, mat) = minimumBy (compare `on` matScore) mats+ matScore (_, m) = score m++rle :: Eq a => [a] -> [(a, Int)]+rle [] = []+rle (x : xs) = case span (== x) xs of+ (xs1, xs') -> (x, length xs1 + 1) : rle xs'++score1 :: Matrix -> Int+score1 m = sum (map s rows) + sum (map s cols)+ where+ (_, (n, _)) = bounds m+ s = sum . map s0 . rle+ s0 (_, i)+ | i < 5 = 0+ | otherwise = i - 2+ rows = [[m ! (x , y) | x <- [0..n]] | y <- [0..n]]+ cols = [[m ! (x , y) | y <- [0..n]] | x <- [0..n]]++score2 :: Matrix -> Int+score2 m = 3 * length (filter solid (indices m))+ where+ solid (x, y) = and+ [ x > 0, y > 0+ , m ! (x - 1, y) == c+ , m ! (x, y - 1) == c+ , m ! (x - 1, y - 1) == c ]+ where c = m ! (x, y)++score3 :: Matrix -> Int+score3 m = 40 * length found+ where+ (_, (n, _)) = bounds m+ cs = range ((11,11),(n,n))+ pt = [ Dark, Light, Dark, Dark, Dark, Light+ , Dark, Light, Light, Light, Light ]+ pts = [pt, reverse pt]+ found = filter (matches (\x y -> m ! (x, y))) cs+ ++ filter (matches (\x y -> m ! (y, x))) cs+ matches mat (x, y) = map (mat y) [x - 10 .. x] `elem` pts++score4 :: Matrix -> Int+score4 m = 10 * deviation+ where+ (_, (n, _)) = bounds m+ darks = length (filter (== Dark) (elems m))+ total = (n + 1) * (n + 1)+ deviation = truncate (abs (fromIntegral darks * (20 :: Double)+ / fromIntegral total - 10))++score :: Matrix -> Int+score m = score1 m + score2 m + score3 m + score4 m++formatInfo :: Level -> Int -> [Bit]+formatInfo l k = toBinary 15 $ pats !! (levelIndex l * 8 + k)+ where+ pats :: [Int]+ pats = [ 30660, 29427, 32170, 30877, 26159, 25368, 27713+ , 26998, 21522, 20773, 24188, 23371, 17913, 16590+ , 20375, 19104, 13663, 12392, 16177, 14854, 9396+ , 8579, 11994, 11245, 5769, 5054, 7399, 6608, 1890+ , 597, 3340, 2107]++versionInfo :: Version -> [Bit]+versionInfo v = toBinary 18 $ pats !! (v - 7)+ where+ pats :: [Int]+ pats = [ 31892, 34236, 39577, 42195, 48118, 51042, 55367+ , 58893, 63784, 68472, 70749, 76311, 79154, 84390+ , 87683, 92361, 96236, 102084, 102881, 110507, 110734+ , 117786, 119615, 126325, 127568, 133589, 136944+ , 141498, 145311, 150283, 152622, 158308, 161089, 167017]++alignment :: Version -> [Int]+alignment 1 = []+alignment 2 = [6, 18]+alignment 3 = [6, 22]+alignment 4 = [6, 26]+alignment 5 = [6, 30]+alignment 6 = [6, 34]+alignment 7 = [6, 22, 38]+alignment 8 = [6, 24, 42]+alignment 9 = [6, 26, 46]+alignment 10 = [6, 28, 50]+alignment 11 = [6, 30, 54]+alignment 12 = [6, 32, 58]+alignment 13 = [6, 34, 62]+alignment 14 = [6, 26, 46, 66]+alignment 15 = [6, 26, 48, 70]+alignment 16 = [6, 26, 50, 74]+alignment 17 = [6, 30, 54, 78]+alignment 18 = [6, 30, 56, 82]+alignment 19 = [6, 30, 58, 86]+alignment 20 = [6, 34, 62, 90]+alignment 21 = [6, 28, 50, 72, 94]+alignment 22 = [6, 26, 50, 74, 98]+alignment 23 = [6, 30, 54, 78, 102]+alignment 24 = [6, 28, 54, 80, 106]+alignment 25 = [6, 32, 58, 84, 110]+alignment 26 = [6, 30, 58, 86, 114]+alignment 27 = [6, 34, 62, 90, 118]+alignment 28 = [6, 26, 50, 74, 98, 122]+alignment 29 = [6, 30, 54, 78, 102, 126]+alignment 30 = [6, 26, 52, 78, 104, 130]+alignment 31 = [6, 30, 56, 82, 108, 134]+alignment 32 = [6, 34, 60, 86, 112, 138]+alignment 33 = [6, 30, 58, 86, 114, 142]+alignment 34 = [6, 34, 62, 90, 118, 146]+alignment 35 = [6, 30, 54, 78, 102, 126, 150]+alignment 36 = [6, 24, 50, 76, 102, 128, 154]+alignment 37 = [6, 28, 54, 80, 106, 132, 158]+alignment 38 = [6, 32, 58, 84, 110, 136, 162]+alignment 39 = [6, 26, 54, 82, 110, 138, 166]+alignment 40 = [6, 30, 58, 86, 114, 142, 170]+alignment n = error $ "alignment: invalid version " ++ show n++{-# ANN module "HLint: ignore Use ++" #-}+{-# ANN module "HLint: ignore Use ||" #-}+{-# ANN showMatrix "HLint: ignore Avoid lambda" #-}+{-# ANN score3 "HLint: ignore Use curry" #-}
+ src/Data/QR/ReedSolomon.hs view
@@ -0,0 +1,80 @@+module Data.QR.ReedSolomon+ ( errorWords+ ) where++import Data.Bits+import Data.Word++raise :: Word8 -> Word8+raise w | w .&. 0x80 == 0 = w'+ | otherwise = w' `xor` 29+ where w' = shiftL w 1++mult :: Word8 -> Word8 -> Word8+mult = go 0+ where+ go a 0 _ = a+ go a x y = go (a `xor` r) x' y'+ where+ x' = shiftR x 1+ y' = raise y+ r = if x .&. 1 == 0 then 0 else y++data Poly a = Poly+ { incDegree :: Int+ , coeff :: [a] }+ deriving (Eq, Read, Show)++mkPoly :: (Eq a, Num a) => [a] -> Poly a+mkPoly xs = Poly (length xs') xs'+ where+ xs' = dropWhile (== 0) xs++polyMod :: Poly Word8 -> Poly Word8 -> Poly Word8+polyMod p q+ | k < 0 = p+ | null as = mkPoly []+ | otherwise = polyMod (mkPoly xs) q+ where+ k = incDegree p - incDegree q+ bs = coeff q ++ replicate k 0+ as = coeff p+ a = head as+ bs' = map (mult a) bs+ xs = zipWith xor as bs'++polyAdd :: Poly Word8 -> Poly Word8 -> Poly Word8+polyAdd p q = mkPoly (zipWith xor as bs)+ where+ d = incDegree p `max` incDegree q+ as = replicate (d - incDegree p) 0 ++ coeff p+ bs = replicate (d - incDegree q) 0 ++ coeff q++polyMult' :: Word8 -> Poly Word8 -> Poly Word8+polyMult' 0 _ = mkPoly []+polyMult' a p = Poly (incDegree p) (map (mult a) (coeff p))++polyRaise :: Poly Word8 -> Poly Word8+polyRaise p = Poly (incDegree p + 1) (coeff p ++ [0])++polyMult :: Poly Word8 -> Poly Word8 -> Poly Word8+polyMult p = go (mkPoly []) (reverse (coeff p))+ where+ go rs [] _ = rs+ go rs (a : as) q =+ go (polyAdd rs (polyMult' a q))+ as (polyRaise q)++gen :: Int -> Poly Word8+gen n | n < 1 = error "invalid generator"+gen n = foldr1 polyMult [mkPoly [1,a] | a <- pows]+ where+ pows = take n $ iterate (mult 2) 1++errorPoly :: Int -> Poly Word8 -> Poly Word8+errorPoly n p = polyMod p' (gen n)+ where+ p' = Poly (incDegree p + n) (coeff p ++ replicate n 0)++errorWords :: Int -> [Word8] -> [Word8]+errorWords n = coeff . errorPoly n . mkPoly
+ src/Data/QR/Tables.hs view
@@ -0,0 +1,216 @@+module Data.QR.Tables+ ( dataBits+ , capacity+ ) where++import Data.QR.Types++dataBits :: Version -> Level -> Int+dataBits v l = values !! ((v - 1) * 4 + levelIndex l)+ where+ values =+ [ 152, 128, 104, 72+ , 272, 224, 176, 128+ , 440, 352, 272, 208+ , 640, 512, 384, 288+ , 864, 688, 496, 368+ , 1088, 864, 608, 480+ , 1248, 992, 704, 528+ , 1552, 1232, 880, 688+ , 1856, 1456, 1056, 800+ , 2192, 1728, 1232, 976+ , 2592, 2032, 1440, 1120+ , 2960, 2320, 1648, 1264+ , 3424, 2672, 1952, 1440+ , 3688, 2920, 2088, 1576+ , 4184, 3320, 2360, 1784+ , 4712, 3624, 2600, 2024+ , 5176, 4056, 2936, 2264+ , 5768, 4504, 3176, 2504+ , 6360, 5016, 3560, 2728+ , 6888, 5352, 3880, 3080+ , 7456, 5712, 4096, 3248+ , 8048, 6256, 4544, 3536+ , 8752, 6880, 4912, 3712+ , 9392, 7312, 5312, 4112+ , 10208, 8000, 5744, 4304+ , 10960, 8496, 6032, 4768+ , 11744, 9024, 6464, 5024+ , 12248, 9544, 6968, 5288+ , 13048, 10136, 7288, 5608+ , 13880, 10984, 7880, 5960+ , 14744, 11640, 8264, 6344+ , 15640, 12328, 8920, 6760+ , 16568, 13048, 9368, 7208+ , 17528, 13800, 9848, 7688+ , 18448, 14496, 10288, 7888+ , 19472, 15312, 10832, 8432+ , 20528, 15936, 11408, 8768+ , 21616, 16816, 12016, 9136+ , 22496, 17728, 12656, 9776+ , 23648, 18672, 13328, 10208 ]++capacity :: Level -> Mode -> Version -> Int+capacity l m v = capacities !! ((v - 1) * 16 + fromEnum l * 4 + fromEnum m)+ where+ capacities =+ [ 41, 25, 17, 10+ , 34, 20, 14, 8+ , 27, 16, 11, 7+ , 17, 10, 7, 4+ , 77, 47, 32, 20+ , 63, 38, 26, 16+ , 48, 29, 20, 12+ , 34, 20, 14, 8+ , 127, 77, 53, 32+ , 101, 61, 42, 26+ , 77, 47, 32, 20+ , 58, 35, 24, 15+ , 187, 114, 78, 48+ , 149, 90, 62, 38+ , 111, 67, 46, 28+ , 82, 50, 34, 21+ , 255, 154, 106, 65+ , 202, 122, 84, 52+ , 144, 87, 60, 37+ , 106, 64, 44, 27+ , 322, 195, 134, 82+ , 255, 154, 106, 65+ , 178, 108, 74, 45+ , 139, 84, 58, 36+ , 370, 224, 154, 95+ , 293, 178, 122, 75+ , 207, 125, 86, 53+ , 154, 93, 64, 39+ , 461, 279, 192, 118+ , 365, 221, 152, 93+ , 259, 157, 108, 66+ , 202, 122, 84, 52+ , 552, 335, 230, 141+ , 432, 262, 180, 111+ , 312, 189, 130, 80+ , 235, 143, 98, 60+ , 652, 395, 271, 167+ , 513, 311, 213, 131+ , 364, 221, 151, 93+ , 288, 174, 119, 74+ , 772, 468, 321, 198+ , 604, 366, 251, 155+ , 427, 259, 177, 109+ , 331, 200, 137, 85+ , 883, 535, 367, 226+ , 691, 419, 287, 177+ , 489, 296, 203, 125+ , 374, 227, 155, 96+ , 1022, 619, 425, 262+ , 796, 483, 331, 204+ , 580, 352, 241, 149+ , 427, 259, 177, 109+ , 1101, 667, 458, 282+ , 871, 528, 362, 223+ , 621, 376, 258, 159+ , 468, 283, 194, 120+ , 1250, 758, 520, 320+ , 991, 600, 412, 254+ , 703, 426, 292, 180+ , 530, 321, 220, 136+ , 1408, 854, 586, 361+ , 1082, 656, 450, 277+ , 775, 470, 322, 198+ , 602, 365, 250, 154+ , 1548, 938, 644, 397+ , 1212, 734, 504, 310+ , 876, 531, 364, 224+ , 674, 408, 280, 173+ , 1725, 1046, 718, 442+ , 1346, 816, 560, 345+ , 948, 574, 394, 243+ , 746, 452, 310, 191+ , 1903, 1153, 792, 488+ , 1500, 909, 624, 384+ , 1063, 644, 442, 272+ , 813, 493, 338, 208+ , 2061, 1249, 858, 528+ , 1600, 970, 666, 410+ , 1159, 702, 482, 297+ , 919, 557, 382, 235+ , 2232, 1352, 929, 572+ , 1708, 1035, 711, 438+ , 1224, 742, 509, 314+ , 969, 587, 403, 248+ , 2409, 1460, 1003, 618+ , 1872, 1134, 779, 480+ , 1358, 823, 565, 348+ , 1056, 640, 439, 270+ , 2620, 1588, 1091, 672+ , 2059, 1248, 857, 528+ , 1468, 890, 611, 376+ , 1108, 672, 461, 284+ , 2812, 1704, 1171, 721+ , 2188, 1326, 911, 561+ , 1588, 963, 661, 407+ , 1228, 744, 511, 315+ , 3057, 1853, 1273, 784+ , 2395, 1451, 997, 614+ , 1718, 1041, 715, 440+ , 1286, 779, 535, 330+ , 3283, 1990, 1367, 842+ , 2544, 1542, 1059, 652+ , 1804, 1094, 751, 462+ , 1425, 864, 593, 365+ , 3517, 2132, 1465, 902+ , 2701, 1637, 1125, 692+ , 1933, 1172, 805, 496+ , 1501, 910, 625, 385+ , 3669, 2223, 1528, 940+ , 2857, 1732, 1190, 732+ , 2085, 1263, 868, 534+ , 1581, 958, 658, 405+ , 3909, 2369, 1628, 1002+ , 3035, 1839, 1264, 778+ , 2181, 1322, 908, 559+ , 1677, 1016, 698, 430+ , 4158, 2520, 1732, 1066+ , 3289, 1994, 1370, 843+ , 2358, 1429, 982, 604+ , 1782, 1080, 742, 457+ , 4417, 2677, 1840, 1132+ , 3486, 2113, 1452, 894+ , 2473, 1499, 1030, 634+ , 1897, 1150, 790, 486+ , 4686, 2840, 1952, 1201+ , 3693, 2238, 1538, 947+ , 2670, 1618, 1112, 684+ , 2022, 1226, 842, 518+ , 4965, 3009, 2068, 1273+ , 3909, 2369, 1628, 1002+ , 2805, 1700, 1168, 719+ , 2157, 1307, 898, 553+ , 5253, 3183, 2188, 1347+ , 4134, 2506, 1722, 1060+ , 2949, 1787, 1228, 756+ , 2301, 1394, 958, 590+ , 5529, 3351, 2303, 1417+ , 4343, 2632, 1809, 1113+ , 3081, 1867, 1283, 790+ , 2361, 1431, 983, 605+ , 5836, 3537, 2431, 1496+ , 4588, 2780, 1911, 1176+ , 3244, 1966, 1351, 832+ , 2524, 1530, 1051, 647+ , 6153, 3729, 2563, 1577+ , 4775, 2894, 1989, 1224+ , 3417, 2071, 1423, 876+ , 2625, 1591, 1093, 673+ , 6479, 3927, 2699, 1661+ , 5039, 3054, 2099, 1292+ , 3599, 2181, 1499, 923+ , 2735, 1658, 1139, 701+ , 6743, 4087, 2809, 1729+ , 5313, 3220, 2213, 1362+ , 3791, 2298, 1579, 972+ , 2927, 1774, 1219, 750+ , 7089, 4296, 2953, 1817+ , 5596, 3391, 2331, 1435+ , 3993, 2420, 1663, 1024+ , 3057, 1852, 1273, 784 ]
+ src/Data/QR/Types.hs view
@@ -0,0 +1,41 @@+module Data.QR.Types where++import Data.List+import Data.Word++type Version = Int+data Mode = Numeric | Alpha | Byte+ deriving (Eq, Ord, Read, Show, Enum)+data Level = L | M | Q | H+ deriving (Eq, Ord, Read, Show, Enum)++levelIndex :: Level -> Int+levelIndex L = 0+levelIndex M = 1+levelIndex Q = 2+levelIndex H = 3++data Bit = Z | O+ deriving (Eq, Ord, Read)++instance Show Bit where+ show Z = "0"+ show O = "1"++toBinary :: Integral a => Int -> a -> [Bit]+toBinary = go []+ where+ go bs n 0 = replicate n Z ++ bs+ go bs n x = case divMod x 2 of+ (x', b) -> go ((if b == 0 then Z else O) : bs) (n - 1) x'++toWords :: [Bit] -> [Word8]+toWords = map toWord . chunksOf 8++toWord :: [Bit] -> Word8+toWord = foldl' (\x b -> x + x + (if b == Z then 0 else 1)) 0++chunksOf :: Int -> [a] -> [[a]]+chunksOf _ [] = []+chunksOf n xs = case splitAt n xs of+ (xs1, xs') -> xs1 : chunksOf n xs'