├── .gitattributes ├── bc_work.xls ├── ada_bar_codes.prj ├── clean.cmd ├── gnat └── debug.pra ├── readme.md ├── ada_bar_codes.txt ├── bar_codes-encode_msi.adb ├── demo └── bar_codes_demo.adb ├── bar_codes_media.ads ├── ada_bar_codes.gpr ├── tools └── bc_gen.adb ├── test └── bar_codes_test.adb ├── bar_codes.adb ├── bar_codes-encode_upca_ean13.adb ├── bar_codes.ads ├── bar_codes-encode_code_128.adb ├── bar_codes-encode_dm.adb ├── bar_codes_media.adb └── bar_codes-encode_qr.adb /.gitattributes: -------------------------------------------------------------------------------- 1 | text eol=lf 2 | -------------------------------------------------------------------------------- /bc_work.xls: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/zertovitch/ada-bar-codes/HEAD/bc_work.xls -------------------------------------------------------------------------------- /ada_bar_codes.prj: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/zertovitch/ada-bar-codes/HEAD/ada_bar_codes.prj -------------------------------------------------------------------------------- /clean.cmd: -------------------------------------------------------------------------------- 1 | del *.pbm 2 | del *.dib 3 | del *.bak 4 | del *pdf.txt 5 | del *.svg 6 | del test*.png -------------------------------------------------------------------------------- /gnat/debug.pra: -------------------------------------------------------------------------------- 1 | pragma Initialize_Scalars; 2 | -- pragma Normalize_Scalars; -- For all units! 3 | -------------------------------------------------------------------------------- /readme.md: -------------------------------------------------------------------------------- 1 | # Ada Bar Codes 2 | 3 | The project Ada Bar Codes provides a package for generating 4 | various types of bar codes, including 2D bar codes like the QR code, 5 | on different output formats, such as PDF, SVG vector graphics or PNG bitmaps. 6 | 7 | The creation of a bar code is as simple as this small procedure: 8 | 9 | ```Ada 10 | with Ada.Text_IO, Bar_Codes, Bar_Codes_Media; 11 | 12 | procedure Small_Demo is 13 | use Ada.Text_IO; 14 | svg : File_Type; 15 | begin 16 | Create (svg, Out_File, "qr_code.svg"); 17 | Put_Line 18 | (svg, 19 | Bar_Codes_Media.SVG_Bar_Code 20 | (Bar_Codes.Code_QR_Low, (5.0, 5.0, 100.0, 100.0), "mm", "Hello")); 21 | Close (svg); 22 | end; 23 | ``` 24 | 25 | **Full description in: `ada_bar_codes.txt`** 26 | -------------------------------------------------------------------------------- /ada_bar_codes.txt: -------------------------------------------------------------------------------- 1 | Intro to Ada Bar Codes 2 | ====================== 3 | 4 | The project Ada Bar Codes provides a package for generating 5 | various types of bar codes, including 2D bar codes like the QR code, 6 | on different output formats, such as PDF, SVG or bitmaps. 7 | 8 | The creation of a bar code is as simple as this small procedure: 9 | 10 | with Ada.Text_IO, Bar_Codes, Bar_Codes_Media; 11 | 12 | procedure Small_Demo is 13 | use Ada.Text_IO; 14 | svg : File_Type; 15 | begin 16 | Create (svg, Out_File, "qr_code.svg"); 17 | Put_Line 18 | (svg, 19 | Bar_Codes_Media.SVG_Bar_Code 20 | (Bar_Codes.Code_QR_Low, 100.0, 100.0, "mm", "Hello")); 21 | Close (svg); 22 | end Small_Demo; 23 | 24 | Contents 25 | ======== 26 | 27 | Ada Bar Codes 28 | ============= 29 | 30 | - ada_bar_codes.gpr : project file for the AdaCore GNAT compiler 31 | - ada_bar_codes.prj : project file for the PTC ObjectAda compiler 32 | - ada_bar_codes.txt : this file 33 | - bar_codes.ads : Bar_Codes package specification 34 | - bar_codes.adb : Bar_Codes package body 35 | - bar_codes-encode* : separate sub-packages of Bar_Codes 36 | - bar_codes_media.ad* : a few simple implementations examples for 37 | the SVG, PDF, PBM and PNG formats 38 | - demo/bar_codes_demo.adb : demo procedure 39 | - test/bar_codes_test.adb : test procedure (produces lots of files!) 40 | 41 | Warning & legal 42 | =============== 43 | There is NO WARRANTY in this software. Read copyright notice in bar_codes.ads. 44 | 45 | Portability 46 | =========== 47 | This software can be compiled for any target machine, and with any compiler 48 | for Ada 2012 or later language versions. 49 | 50 | How to build Ada Bar Codes and its demo 51 | ======================================= 52 | Here is how to build with GNAT/GCC: 53 | 54 | - type "gprbuild -P ada_bar_codes" in the command line 55 | or 56 | - type "gnatmake -P ada_bar_codes" in the command line 57 | or 58 | - open the ada_bar_codes.gpr file (will launch GNAT Studio), 59 | press F4 (Build) 60 | 61 | Here is how to build with ObjectAda (tested with v.9.2): 62 | - open the ada_bar_codes_oa.prj file, press F7 (Build) 63 | 64 | The project builds bar_codes_demo[.exe] and bar_codes_test[.exe]. 65 | 66 | Thanks to... 67 | ============ 68 | 69 | Giuseppe Cannone, for the inspiration and advice. 70 | 71 | Jeffrey R. Carter, for the first implementation on raster graphics 72 | and as a Web service: https://github.com/jrcarter/Gnoga_Bar_Codes 73 | 74 | Nicolas Boulenguez , 75 | for numerous suggestions and improvements. 76 | 77 | On the Web 78 | ========== 79 | Home page: http://ada-bar-codes.sf.net/ 80 | Project page: http://sf.net/projects/ada-bar-codes/ 81 | Mirror: https://github.com/zertovitch/ada-bar-codes 82 | Alire crate: https://alire.ada.dev/crates/bar_codes 83 | 84 | -- 85 | Enjoy! 86 | 87 | Gautier de Montmollin 88 | gautier.de.montmollin, at: gmail dot com. -------------------------------------------------------------------------------- /bar_codes-encode_msi.adb: -------------------------------------------------------------------------------- 1 | separate (Bar_Codes) 2 | 3 | package body Encode_MSI is 4 | 5 | -- Adapted from Bar_Code_Drawing: 6 | -- 7 | -- Drawing MSI bar codes (also called MSI Plessey and Modified Plessey) 8 | -- 9 | -- Copyright (C) by PragmAda Software Engineering 10 | -- 11 | -- Released under the terms of the 3-Clause BSD License. 12 | -- See https://opensource.org/licenses/BSD-3-Clause 13 | 14 | subtype Digit_Value is Integer range 0 .. 9; 15 | subtype Digit is Character range '0' .. '9'; 16 | function D2N (D : Digit) return Digit_Value is (Character'Pos (D) - Character'Pos ('0')); 17 | 18 | function Luhn_Check_Digit (input : String) return Digit_Value is 19 | -- Compute the extra digit x such that the Luhn checksum is 0. 20 | sum : Natural := 0; 21 | d, x : Natural; 22 | odd_10_power : Boolean := True; 23 | begin 24 | for char of reverse input loop 25 | d := D2N (char); 26 | if odd_10_power then 27 | d := 2 * d; 28 | if d > 9 then 29 | d := d - 9; 30 | end if; 31 | end if; 32 | sum := sum + d; 33 | odd_10_power := not odd_10_power; 34 | end loop; 35 | x := 9 * sum; -- We want (x + sum) to be congruent to 0, modulo 10. 36 | return x rem 10; 37 | end Luhn_Check_Digit; 38 | 39 | Symbol_Width : constant := 12; -- Each digit has 4 bits of 3 bars 40 | Start_Width : constant := 3; -- Start symbol is a 1 bit 41 | Stop_Width : constant := 4; -- Stop symbol is 00; trailing white bars ignored 42 | 43 | function Valid (text : String) return Boolean is 44 | (for all C of text => C in Digit); 45 | 46 | function Code_Modules_Width (text : String) return Positive is 47 | (Symbol_Width * (text'Length + 1) + Start_Width + Stop_Width); -- +1 for Luhn check digit 48 | 49 | procedure Draw (bc : in out Bar_Code; text : String) is 50 | 51 | procedure Bar (offset, width : Natural) is 52 | begin 53 | Filled_Rectangle 54 | (Bar_Code'Class (bc), -- Will use the concrete child method for displaying a rectangle 55 | (left => offset, 56 | bottom => 0, 57 | width => width, 58 | height => 1)); 59 | end Bar; 60 | 61 | X : Natural := 0; 62 | 63 | procedure Draw_Bit (Bit : in Natural) is 64 | begin 65 | Bar (X, (if Bit = 0 then 1 else 2)); 66 | X := X + 3; 67 | end Draw_Bit; 68 | 69 | procedure Draw_Nibble (n : Digit_Value) is 70 | begin 71 | Draw_Bit (n / 8); 72 | Draw_Bit (n / 4 mod 2); 73 | Draw_Bit (n / 2 mod 2); 74 | Draw_Bit (n mod 2); 75 | end Draw_Nibble; 76 | 77 | begin 78 | if not Valid (text) then 79 | raise Cannot_Encode with "Message must be all in decimal digits"; 80 | end if; 81 | 82 | Draw_Bit (1); -- Start code 83 | for C of text loop 84 | Draw_Nibble (D2N (C)); 85 | end loop; 86 | Draw_Nibble (Luhn_Check_Digit (text)); 87 | Draw_Bit (0); -- Stop code 88 | Draw_Bit (0); 89 | end Draw; 90 | 91 | function Fitting (text : String) return Module_Box is 92 | (0, 0, Code_Modules_Width (text), 1); 93 | 94 | end Encode_MSI; 95 | -------------------------------------------------------------------------------- /demo/bar_codes_demo.adb: -------------------------------------------------------------------------------- 1 | --------------------------------------------------- 2 | -- The big... Ada Bar Codes Demo (ABCD :-) ) ! -- 3 | --------------------------------------------------- 4 | 5 | with Ada.Streams.Stream_IO, 6 | Ada.Text_IO; 7 | 8 | with Bar_Codes, Bar_Codes_Media; 9 | 10 | procedure Bar_Codes_Demo is 11 | 12 | -- SVG files (bar_code_128.svg, dm_code.svg, qr_code_l.svg) can be viewed 13 | -- directly in a Web browser. 14 | -- 15 | -- PDF snippets need to be included into a PDF document. 16 | -- For instance, use Insert_Graphics_PDF_Code of PDF_Out, http://apdf.sf.net/ 17 | -- 18 | -- PBM images demonstrate output as raster graphics. This could be another image 19 | -- format, or anything else involving pixels, like a screen, a printer, etc. 20 | -- 21 | -- PNG images demonstrate output as raster graphics for the ubiquitous PNG format. 22 | -- 23 | use Ada.Text_IO; 24 | svg, pdf, pbm : File_Type; 25 | 26 | package SIO renames Ada.Streams.Stream_IO; 27 | png : SIO.File_Type; 28 | 29 | procedure SVG_Header is 30 | -- NB: the SVG file can be viewed without this header. 31 | begin 32 | Put_Line (svg, ""); 33 | Put_Line (svg, ""); 36 | end SVG_Header; 37 | 38 | prefix : constant String := "Hello from " & Bar_Codes.title; 39 | hello_short : constant String := prefix & "! How's life?"; 40 | hello_long : constant String := prefix & " ( " & Bar_Codes.web & " ) ! My number is: 1234567890"; 41 | 42 | procedure Demo_Code_128 is 43 | use Bar_Codes, Bar_Codes_Media; 44 | begin 45 | Create (svg, Out_File, "bar_code_128.svg"); 46 | SVG_Header; 47 | Put_Line (svg, SVG_Bar_Code (Code_128, (0.0, 0.0, 57.0, 23.0), "mm", hello_short)); 48 | Close (svg); 49 | -- 50 | Create (pdf, Out_File, "bar_code_128_pdf.txt"); 51 | Put_Line (pdf, PDF_Bar_Code (Code_128, (150.0, 320.0, 600.0, 50.0), hello_short)); 52 | Close (pdf); 53 | -- 54 | Create (pbm, Out_File, "bar_code_128.pbm"); 55 | Put_Line (pbm, PBM_Bar_Code (Code_128, 2, 100, hello_short)); 56 | Close (pbm); 57 | -- 58 | SIO.Create (png, SIO.Out_File, "bar_code_128.png"); 59 | PNG_Bar_Code (Code_128, 2, 100, hello_short, SIO.Stream (png).all); 60 | SIO.Close (png); 61 | end Demo_Code_128; 62 | 63 | procedure Demo_MSI is 64 | use Bar_Codes, Bar_Codes_Media; 65 | begin 66 | SIO.Create (png, SIO.Out_File, "bar_code_msi.png"); 67 | PNG_Bar_Code (Code_MSI, 2, 100, "12345678901", SIO.Stream (png).all); 68 | SIO.Close (png); 69 | end Demo_MSI; 70 | 71 | procedure Demo_UPCA is 72 | use Bar_Codes, Bar_Codes_Media; 73 | begin 74 | SIO.Create (png, SIO.Out_File, "bar_code_upca.png"); 75 | PNG_Bar_Code (Code_UPCA, 2, 100, "12345678901", SIO.Stream (png).all); 76 | SIO.Close (png); 77 | end Demo_UPCA; 78 | 79 | procedure Demo_EAN13 is 80 | use Bar_Codes, Bar_Codes_Media; 81 | begin 82 | SIO.Create (png, SIO.Out_File, "bar_code_ean13.png"); 83 | PNG_Bar_Code (Code_EAN13, 2, 100, "123456789012", SIO.Stream (png).all); 84 | SIO.Close (png); 85 | end Demo_EAN13; 86 | 87 | procedure Demo_QR is 88 | use Bar_Codes, Bar_Codes_Media; 89 | begin 90 | Create (svg, Out_File, "qr_code_l.svg"); 91 | SVG_Header; 92 | Put_Line (svg, SVG_Bar_Code (Code_QR_Low, (3.0, 3.0, 60.0, 60.0), "mm", hello_long)); 93 | Close (svg); 94 | -- 95 | Create (pdf, Out_File, "qr_code_q_pdf.txt"); 96 | Put_Line (pdf, PDF_Bar_Code (Code_QR_Quartile, (150.0, 120.0, 100.0, 100.0), hello_long)); 97 | Close (pdf); 98 | -- 99 | Create (pbm, Out_File, "qr_code_h.pbm"); 100 | Put_Line (pbm, PBM_Bar_Code (Code_QR_High, 5, 5, hello_long)); 101 | Close (pbm); 102 | -- 103 | SIO.Create (png, SIO.Out_File, "qr_code_h.png"); 104 | PNG_Bar_Code (Code_QR_High, 5, 5, hello_long, SIO.Stream (png).all); 105 | SIO.Close (png); 106 | end Demo_QR; 107 | 108 | procedure Demo_Data_Matrix is 109 | use Bar_Codes, Bar_Codes_Media; 110 | begin 111 | Create (svg, Out_File, "dm_code.svg"); 112 | SVG_Header; 113 | Put_Line (svg, SVG_Bar_Code (Code_DM_Square, (3.0, 3.0, 80.0, 80.0), "mm", hello_long)); 114 | Close (svg); 115 | -- 116 | Create (pbm, Out_File, "dm_code_rect.pbm"); 117 | Put_Line (pbm, PBM_Bar_Code (Code_DM_Rectangular, 10, 10, hello_short)); 118 | Close (pbm); 119 | -- 120 | SIO.Create (png, SIO.Out_File, "dm_code_rect.png"); 121 | PNG_Bar_Code (Code_DM_Rectangular, 10, 10, hello_short, SIO.Stream (png).all); 122 | SIO.Close (png); 123 | end Demo_Data_Matrix; 124 | 125 | begin 126 | Demo_Code_128; 127 | Demo_MSI; 128 | Demo_UPCA; 129 | Demo_EAN13; 130 | Demo_QR; 131 | Demo_Data_Matrix; 132 | end Bar_Codes_Demo; 133 | -------------------------------------------------------------------------------- /bar_codes_media.ads: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------- 2 | -- Ready-to-use implementations of the bar code generator: -- 3 | -- -- 4 | -- - PDF_Bar_Code : PDF vector graphics for PDF documents -- 5 | -- - SVG_Bar_Code : SVG vector graphics for Web contents -- 6 | -- - PBM_Bar_Code : PBM bitmap image (raster graphics) -- 7 | -- - PNG_Bar_Code : PNG bitmap image (raster graphics) -- 8 | -- -- 9 | ---------------------------------------------------------------- 10 | -- 11 | -- Important note 12 | -- 13 | -- Vector graphics and raster graphics are fundamentally different 14 | -- regarding the production of bar codes: 15 | -- 16 | -- - On vector graphics, lengths are arbitrarily divisible. So it 17 | -- is possible to define a rectangle and let Bar_Codes 18 | -- fill that rectangle with the bar code. 19 | -- 20 | -- - On raster graphics, the bar code generator *has* to produce integer 21 | -- amounts of pixels. The only freedom is the scaling, by an integer amount 22 | -- as well. Furthermore: 23 | -- - On some screens or other devices, pixels are not 24 | -- displayed as squares. Sad! 25 | -- - Modules of certain 2D bar codes (such as QR) are best rendered 26 | -- squared. 27 | -- - Consequently, for such 2D bar codes, scale_x = scale_y is not 28 | -- always, automatically, the appropriate setting. 29 | -- Check the output media's aspect ratio. 30 | 31 | with Bar_Codes; 32 | 33 | with Ada.Streams; 34 | 35 | package Bar_Codes_Media is 36 | 37 | ----------------------------------------------------------------------------------- 38 | -- Vector Graphics - PDF -- 39 | ----------------------------------------------------------------------------------- 40 | -- The PDF_Bar_Code function produces a PDF (Portable Document Format) snippet -- 41 | -- to be included into a PDF document. For instance, you can use -- 42 | -- Insert_Graphics_PDF_Code of package PDF_Out (project Ada PDF Writer, -- 43 | -- http://apdf.sf.net/ ) for such an inclusion. -- 44 | ----------------------------------------------------------------------------------- 45 | 46 | function PDF_Bar_Code 47 | (kind : Bar_Codes.Kind_Of_Code; 48 | bounding : Bar_Codes.Box; -- Box in the PDF page, containing the bar code 49 | text : String) -- Text to encode 50 | return String; 51 | 52 | ----------------------------------------------------------------------------------- 53 | -- Vector Graphics - SVG -- 54 | ----------------------------------------------------------------------------------- 55 | -- The SVG_Bar_Code function produces a SVG (Scalable Vector Graphics) object. -- 56 | -- You can view directly a SVG image with most Web browsers, or include it in -- 57 | -- an HTML document. -- 58 | ----------------------------------------------------------------------------------- 59 | 60 | function SVG_Bar_Code 61 | (kind : Bar_Codes.Kind_Of_Code; 62 | bounding : Bar_Codes.Box; -- Box in the SVG plane, containing the bar code 63 | unit : String; -- Length unit, for instance "mm" for millimeter 64 | text : String) -- Text to encode 65 | return String; 66 | 67 | ------------------------------------------------------------------------------- 68 | -- Raster Graphics - PBM -- 69 | ------------------------------------------------------------------------------- 70 | -- The PBM_Bar_Code function produces a PBM (Portable BitMap) image. -- 71 | -- This simple image format is supported by GIMP ( https://www.gimp.org/ ) -- 72 | -- or GID ( https://gen-img-dec.sourceforge.io/ ) -- 73 | ------------------------------------------------------------------------------- 74 | 75 | function PBM_Bar_Code 76 | (kind : Bar_Codes.Kind_Of_Code; 77 | scale_x, scale_y : Positive; -- Scaling factors for the bitmap rendering 78 | text : String) -- Text to encode 79 | return String; 80 | 81 | ---------------------------------------------- 82 | -- Raster Graphics - PNG -- 83 | ---------------------------------------------- 84 | -- The PNG_Bar_Code procedure produces a -- 85 | -- PNG (Portable Network Graphics) image. -- 86 | ---------------------------------------------- 87 | 88 | procedure PNG_Bar_Code 89 | (kind : in Bar_Codes.Kind_Of_Code; 90 | scale_x, scale_y : in Positive; -- Scaling factors for the bitmap rendering 91 | text : in String; -- Text to encode 92 | output : in out Ada.Streams.Root_Stream_Type'Class); 93 | 94 | end Bar_Codes_Media; 95 | -------------------------------------------------------------------------------- /ada_bar_codes.gpr: -------------------------------------------------------------------------------- 1 | -- This is a GNAT, GCC or GNAT Studio project file 2 | -- for the Ada Bar Codes project: 3 | -- 4 | -- Home page: http://ada-bar-codes.sf.net/ 5 | -- Project page: http://sf.net/projects/ada-bar-codes/ 6 | -- Mirror: https://github.com/zertovitch/ada-bar-codes 7 | -- Alire crate: https://alire.ada.dev/crates/bar_codes 8 | -- 9 | -- Build me with "gprbuild -P ada_bar_codes", or "gnatmake -P ada_bar_codes", 10 | -- or open me with GNAT Studio 11 | -- 12 | project Ada_Bar_Codes is 13 | 14 | type ABC_Build_Mode_Type is 15 | ("Debug", 16 | "Fast", 17 | "dynamic", "relocatable", -- shared library (PIC) 18 | "static", -- static library (non PIC) 19 | "static-pic"); -- static library (PIC) 20 | 21 | ABC_Build_Mode : ABC_Build_Mode_Type := external ("ABC_Build_Mode", "Debug"); 22 | 23 | Adaflags := External_As_List ("ADAFLAGS", " "); 24 | Ldflags := External_As_List ("LDFLAGS", " "); 25 | 26 | Library_Version := External ("ABC_Library_Version", "libada_bar_codes.so.1"); 27 | 28 | for Create_Missing_Dirs use "True"; -- Flips the "-p" switch 29 | 30 | case ABC_Build_Mode is 31 | when "Debug" | "Fast" => 32 | for Source_Dirs use 33 | (".", -- Library: Bar_Codes[.*] 34 | "demo", -- Demos 35 | "test", -- Tests 36 | "tools"); -- Tools 37 | for Main use 38 | ("bar_codes_demo.adb", -- Main demo 39 | "bar_codes_test.adb", -- Tests 40 | "bc_gen.adb"); -- Tools 41 | for Exec_Dir use "."; 42 | for Object_Dir use "obj/" & ABC_Build_Mode; 43 | when "dynamic" | "relocatable" => 44 | for Source_Dirs use ("."); 45 | for Library_Name use "ada_bar_codes"; 46 | for Library_Kind use "relocatable"; 47 | for Library_Version use Library_Version; 48 | for Leading_Library_Options use Ldflags; 49 | for Library_Dir use "obj/relocatable-lib"; 50 | for Object_Dir use "obj/relocatable-obj"; 51 | when "static" | "static-pic" => 52 | for Source_Dirs use ("."); 53 | for Library_Name use "ada_bar_codes"; 54 | for Library_Kind use ABC_Build_Mode; 55 | for Library_Dir use "obj/" & ABC_Build_Mode & "-lib"; 56 | for Object_Dir use "obj/" & ABC_Build_Mode & "-obj"; 57 | end case; 58 | 59 | Compiler_Common_Options := 60 | ("-gnatwaC", -- Warnings switches (a:turn on all info/warnings marked with +; C:turn off warnings for constant conditional) 61 | "-gnatwh", -- Warnings switches (h:turn on warnings for hiding declarations) 62 | "-gnatwijkmopruvz.c.p.t.w.x", -- Warnings switches (run "gnatmake" for full list) 63 | "-gnatf", -- Full errors. Verbose details, all undefined references 64 | "-gnatq", -- Don't quit, try semantics, even if parse errors 65 | "-gnatQ") -- Don't quit, write ali/tree file even if compile errors 66 | & 67 | ("-gnatyaknpr", -- Style: check all casings: a:attribute, k:keywords, n:package Standard identifiers, p:pragma, r:identifier references 68 | "-gnatybfhiu", -- Style: check b:no blanks at end of lines, f:no ff/vtabs, h: no htabs, i:if-then layout, u:no unnecessary blank lines 69 | "-gnatyxtc", -- Style: check x:no extra parens, t:token separation rules, c:comment format (two spaces) 70 | "-gnatye", -- Style: check e:end/exit labels present 71 | "-gnaty2", -- Style: check indentation 72 | "-gnatyO") -- Style: check O:check overriding indicators 73 | 74 | & Adaflags; 75 | 76 | Compiler_Debug_Options := 77 | ("-gnato", "-fno-inline", "-fstack-check", "-g", "-gnatVa") & 78 | Compiler_Common_Options; 79 | 80 | Compiler_Fast_Options := 81 | ("-Ofast", "-gnatn") & 82 | Compiler_Common_Options; 83 | 84 | package Compiler is 85 | case ABC_Build_Mode is 86 | when "Debug" => 87 | for Local_Configuration_Pragmas use project'Project_Dir & "gnat/debug.pra"; 88 | for Default_Switches ("ada") use Compiler_Debug_Options; 89 | when others => 90 | for Default_Switches ("ada") use Compiler_Fast_Options; 91 | end case; 92 | end Compiler; 93 | 94 | package Binder is 95 | -- -Es: Store tracebacks in exception occurrences, and enable symbolic tracebacks 96 | for Default_Switches ("ada") use ("-Es"); 97 | end Binder; 98 | 99 | package Builder is 100 | -- "If -j0 is used, then the maximum number of simultaneous compilation 101 | -- jobs is the number of core processors on the platform." 102 | for Default_Switches ("ada") use ("-j0"); 103 | end Builder; 104 | 105 | package Linker is 106 | case ABC_Build_Mode is 107 | when "Debug" => for Switches ("Ada") use Ldflags; 108 | when others => null; 109 | end case; 110 | end Linker; 111 | 112 | end Ada_Bar_Codes; 113 | -------------------------------------------------------------------------------- /tools/bc_gen.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- BC_Gen * Generate bar codes from the command line. 3 | -- 4 | 5 | with Bar_Codes, Bar_Codes_Media; 6 | 7 | with Ada.Characters.Handling, 8 | Ada.Command_Line, 9 | Ada.Streams.Stream_IO, 10 | Ada.Strings.Unbounded, 11 | Ada.Text_IO; 12 | 13 | procedure BC_Gen is 14 | 15 | use Ada.Characters.Handling, Ada.Streams.Stream_IO, Ada.Strings.Unbounded, Ada.Text_IO; 16 | 17 | procedure Blurb is 18 | begin 19 | Put_Line (Current_Error, "BC_Gen * Generate bar codes from the command line"); 20 | Put_Line 21 | (Current_Error, 22 | "Using " & Bar_Codes.title & ' ' & Bar_Codes.version & " dated " & Bar_Codes.reference); 23 | Put_Line (Current_Error, "URL: " & Bar_Codes.web); 24 | New_Line (Current_Error); 25 | Put_Line (Current_Error, "Syntax:"); 26 | Put_Line (Current_Error, "bc_gen [options] text"); 27 | New_Line (Current_Error); 28 | Put_Line (Current_Error, "Options:"); 29 | New_Line (Current_Error); 30 | Put_Line (Current_Error, " -qr : QR code (default)"); 31 | Put_Line (Current_Error, " -dm : Data Matrix code"); 32 | Put_Line (Current_Error, " -ean : EAN13 code"); 33 | Put_Line (Current_Error, " -upca : UPCA code"); 34 | Put_Line (Current_Error, " -msi : MSI code"); 35 | Put_Line (Current_Error, " -128 : code 128"); 36 | New_Line (Current_Error); 37 | Put_Line (Current_Error, " -png : Output as PNG image (default)"); 38 | Put_Line (Current_Error, " -svg : Output as SVG image"); 39 | New_Line (Current_Error); 40 | Put_Line (Current_Error, " -ofile : Output to "); 41 | New_Line (Current_Error); 42 | Put (Current_Error, "Press Return"); 43 | Skip_Line; 44 | return; 45 | end Blurb; 46 | 47 | kind : Bar_Codes.Kind_Of_Code := Bar_Codes.Code_QR_High; 48 | 49 | type Format_Type is (PNG, SVG); 50 | 51 | format : Format_Type := PNG; 52 | 53 | text, file_name : Unbounded_String := Null_Unbounded_String; 54 | 55 | function Final_File_Name return String is 56 | (if file_name = Null_Unbounded_String then 57 | -- Default name: 58 | (case format is 59 | when PNG => "output.png", 60 | when SVG => "output.svg") 61 | else 62 | To_String (file_name)); 63 | 64 | package SIO renames Ada.Streams.Stream_IO; 65 | package TIO renames Ada.Text_IO; 66 | 67 | stm_out : SIO.File_Type; 68 | txt_out : TIO.File_Type; 69 | 70 | procedure SVG_Header is 71 | -- NB: the SVG file can be viewed without this header. 72 | begin 73 | Put_Line (txt_out, ""); 74 | Put_Line (txt_out, ""); 77 | end SVG_Header; 78 | 79 | use Ada.Command_Line, Bar_Codes; 80 | 81 | begin 82 | if Argument_Count = 0 then 83 | Blurb; 84 | return; 85 | end if; 86 | 87 | for i in 1 .. Argument_Count loop 88 | declare 89 | arg : constant String := Argument (i); 90 | begin 91 | if arg'Length >= 2 and then arg (arg'First) = '-' then 92 | declare 93 | opt : constant String := To_Lower (arg (arg'First + 1 .. arg'Last)); 94 | begin 95 | if opt = "qr" then 96 | kind := Bar_Codes.Code_QR_High; 97 | elsif opt = "dm" then 98 | kind := Bar_Codes.Code_DM_Square; 99 | elsif opt = "ean" then 100 | kind := Bar_Codes.Code_EAN13; 101 | elsif opt = "upca" then 102 | kind := Bar_Codes.Code_UPCA; 103 | elsif opt = "msi" then 104 | kind := Bar_Codes.Code_MSI; 105 | elsif opt = "128" then 106 | kind := Bar_Codes.Code_128; 107 | elsif opt = "png" then 108 | format := PNG; 109 | elsif opt = "svg" then 110 | format := SVG; 111 | elsif opt (opt'First) = 'o' then 112 | file_name := To_Unbounded_String (opt (opt'First + 1 .. opt'Last)); 113 | else 114 | Put_Line (Current_Error, "Unknown option: " & arg); 115 | end if; 116 | end; 117 | else 118 | text := To_Unbounded_String (arg); 119 | end if; 120 | end; 121 | end loop; 122 | 123 | if text = Null_Unbounded_String then 124 | Blurb; 125 | else 126 | case format is 127 | 128 | when PNG => 129 | SIO.Create (stm_out, SIO.Out_File, Final_File_Name); 130 | Bar_Codes_Media.PNG_Bar_Code 131 | (kind => kind, 132 | scale_x => 5, 133 | scale_y => (if kind in Code_1D then 100 else 5), 134 | text => To_String (text), 135 | output => SIO.Stream (stm_out).all); 136 | SIO.Close (stm_out); 137 | 138 | when SVG => 139 | TIO.Create (txt_out, TIO.Out_File, Final_File_Name); 140 | SVG_Header; 141 | TIO.Put_Line 142 | (txt_out, 143 | Bar_Codes_Media.SVG_Bar_Code 144 | (kind => kind, 145 | bounding => 146 | (3.0, 147 | 3.0, 148 | 57.0, 149 | (if kind in Code_1D then 23.0 else 57.0)), 150 | unit => "mm", 151 | text => To_String (text))); 152 | TIO.Close (txt_out); 153 | 154 | end case; 155 | end if; 156 | end BC_Gen; 157 | -------------------------------------------------------------------------------- /test/bar_codes_test.adb: -------------------------------------------------------------------------------- 1 | with Ada.Characters.Handling, 2 | Ada.Numerics.Float_Random, 3 | Ada.Streams.Stream_IO; 4 | 5 | with Bar_Codes, Bar_Codes_Media; 6 | 7 | procedure Bar_Codes_Test is 8 | 9 | procedure Spit (kind : Bar_Codes.Kind_Of_Code; file_name_part, text : String) is 10 | use Bar_Codes, Bar_Codes_Media; 11 | use Ada.Characters.Handling, Ada.Streams.Stream_IO; 12 | png : File_Type; 13 | prefix : constant String := "test " & To_Lower (kind'Image) & ' '; 14 | begin 15 | if file_name_part = "" then 16 | Create (png, Out_File, prefix & text & ".png"); 17 | else 18 | Create (png, Out_File, prefix & file_name_part & ".png"); 19 | end if; 20 | if Code_2D_Square (kind) then 21 | -- Square 2D codes need square modules. 22 | PNG_Bar_Code (kind, 2, 2, text, Stream (png).all); 23 | else 24 | case kind is 25 | when Code_1D => 26 | -- 1D modules are as high as you wish. 27 | PNG_Bar_Code (kind, 2, 30, text, Stream (png).all); 28 | when Code_DM_Rectangular => 29 | PNG_Bar_Code (kind, 2, 2, text, Stream (png).all); 30 | when others => 31 | pragma Assert (Code_2D_Square (kind)); 32 | end case; 33 | end if; 34 | Close (png); 35 | end Spit; 36 | 37 | procedure Test_128 is 38 | use Bar_Codes; 39 | use Ada.Numerics.Float_Random; 40 | chunks : constant := 2; 41 | c : Character := ASCII.DEL; 42 | msg : String (1 .. 128 / chunks); 43 | rnd : String (1 .. 50); 44 | gen : Generator; 45 | n : Positive; 46 | begin 47 | for chunk in 1 .. chunks loop 48 | for i in msg'Range loop 49 | msg (i) := c; 50 | if c > ASCII.NUL then 51 | c := Character'Pred (c); 52 | end if; 53 | end loop; 54 | Spit (Code_128, chunk'Image, msg); 55 | end loop; 56 | Spit (Code_128, "vn1", "0520"); 57 | Spit (Code_128, "vn2", "993512176004535560"); 58 | Spit (Code_128, "", "12345abc1234abc1234567a123bcdef12345"); 59 | Reset (gen, 1); 60 | for iter in 1 .. 9 loop 61 | for i in rnd'Range loop 62 | rnd (i) := Character'Val (32 + Integer (Random (gen) * 95.0)); 63 | end loop; 64 | -- Put a few non-printable characters... 65 | for i in rnd'Range loop 66 | if Random (gen) < 0.1 then 67 | rnd (i) := ASCII.ESC; 68 | end if; 69 | end loop; 70 | -- Put a few sequences of digits... 71 | for i in rnd'Range loop 72 | if Random (gen) < 0.08 then 73 | n := 1 + Integer (Random (gen) * 6.0); 74 | for j in i .. Integer'Min (rnd'Last, i + n) loop 75 | rnd (j) := Character'Val (Character'Pos ('0') + Integer (Random (gen) * 9.0)); 76 | end loop; 77 | end if; 78 | end loop; 79 | Spit (Code_128, "rnd" & iter'Image, rnd); 80 | -- Digits only (must be all with subcode C): 81 | for i in rnd'Range loop 82 | rnd (i) := Character'Val (Character'Pos ('0') + Integer (Random (gen) * 9.0)); 83 | end loop; 84 | Spit (Code_128, "rnd digits" & iter'Image, rnd); 85 | end loop; 86 | end Test_128; 87 | 88 | procedure Test_MSI is 89 | begin 90 | Spit (Bar_Codes.Code_MSI, "", "1234567890"); 91 | Spit (Bar_Codes.Code_MSI, "", "1234576890"); 92 | Spit (Bar_Codes.Code_MSI, "", "12345678901"); 93 | Spit (Bar_Codes.Code_MSI, "", "998877665544332211"); 94 | Spit (Bar_Codes.Code_MSI, "", "97531"); 95 | Spit (Bar_Codes.Code_MSI, "", "24680"); 96 | end Test_MSI; 97 | 98 | procedure Test_EAN13 is 99 | begin 100 | for initial_digit in Character range '0' .. '9' loop 101 | Spit (Bar_Codes.Code_EAN13, (1 => initial_digit), initial_digit & "12345678901"); 102 | end loop; 103 | end Test_EAN13; 104 | 105 | procedure Test_UPCA is 106 | begin 107 | Spit (Bar_Codes.Code_UPCA, "", "12345678901"); 108 | end Test_UPCA; 109 | 110 | procedure Test_2D is 111 | blabla : constant String := 112 | "The Corporate Bullshit Generator " & 113 | " *** " & 114 | "Short URL (for bookmark and sharing): http://cbsg.sf.net " & 115 | " *** " & 116 | "A pre-integrated, non-deterministic and high-performance intellect " & 117 | "deepens mobility spaces. " & 118 | "Offshorings expediently generate our world-class and fast-paced brand image. " & 119 | "A segmentation influences the decision makers, while multi-divisional, " & 120 | "service-oriented, pipelines quickly streamline evolutions. " & 121 | "Above-average next steps incentivise the initiator; nevertheless " & 122 | "the enablers orchestrate the adjustments. A continual increase in " & 123 | "margins goes hand-in-hand with a measured gain in task efficiency." & 124 | " *** " & 125 | "The project Ada Bar Codes provides a package for generating " & 126 | "various types of bar codes on different output formats," & 127 | "such as PDF, SVG or bitmaps." & 128 | " *** " & 129 | "Zip-Ada is a programming library for dealing with the Zip compressed " & 130 | "archive file format. The full sources of Zip-Ada are in Ada, " & 131 | "compilable on every compiler and for every system. For more details, " & 132 | "read the files zipada.txt and zip.ads from the archive below." & 133 | " *** " & 134 | "GLOBE_3D stands for GL Object Based Engine for 3D." & 135 | "GL stands for Graphics Library, created by SGI. " & 136 | "SGI stands for Silicon Graphics, Inc. " & 137 | "Short description: GLOBE_3D is a free, open-source," & 138 | "real-time 3D Engine written in Ada, based on OpenGL."; 139 | begin 140 | for c in Bar_Codes.Code_2D loop 141 | Spit (c, "blabla 0001", blabla (1 .. 0001)); 142 | Spit (c, "blabla 0010", blabla (1 .. 0010)); 143 | Spit (c, "blabla 0035", blabla (1 .. 0035)); 144 | Spit (c, "blabla 0100", blabla (1 .. 0100)); 145 | Spit (c, "blabla 0250", blabla (1 .. 0250)); 146 | Spit (c, "blabla 0500", blabla (1 .. 0500)); 147 | Spit (c, "blabla full", blabla); 148 | end loop; 149 | end Test_2D; 150 | begin 151 | Test_128; 152 | Test_MSI; 153 | Test_EAN13; 154 | Test_UPCA; 155 | Test_2D; 156 | end Bar_Codes_Test; 157 | -------------------------------------------------------------------------------- /bar_codes.adb: -------------------------------------------------------------------------------- 1 | with Ada.Text_IO; 2 | 3 | package body Bar_Codes is 4 | 5 | package Encode_Code_128 is 6 | procedure Draw (bc : in out Bar_Code; text : String); 7 | function Fitting (text : String) return Module_Box; 8 | end Encode_Code_128; 9 | -- 10 | package body Encode_Code_128 is separate; 11 | 12 | package Encode_MSI is 13 | procedure Draw (bc : in out Bar_Code; text : String); 14 | function Fitting (text : String) return Module_Box; 15 | end Encode_MSI; 16 | -- 17 | package body Encode_MSI is separate; 18 | 19 | package Encode_UPCA_EAN13 is 20 | procedure Draw (bc : in out Bar_Code; text : String; kind : Code_UPCA_EAN13); 21 | function Fitting return Module_Box; 22 | end Encode_UPCA_EAN13; 23 | -- 24 | package body Encode_UPCA_EAN13 is separate; 25 | 26 | package Encode_DM is 27 | procedure Draw (bc : in out Bar_Code; text : String; dm_kind : Code_DM); 28 | function Fitting (text : String; dm_kind : Code_DM) return Module_Box; 29 | end Encode_DM; 30 | -- 31 | package body Encode_DM is separate; 32 | 33 | package Encode_QR is 34 | procedure Draw (bc : in out Bar_Code; text : String; qr_kind : Code_QR); 35 | function Fitting (text : String; qr_kind : Code_QR) return Module_Box; 36 | end Encode_QR; 37 | -- 38 | package body Encode_QR is separate; 39 | 40 | ------------------------ 41 | -- Bar_Code methods -- 42 | ------------------------ 43 | 44 | procedure Set_Bounding_Box (bc : in out Bar_Code; bounding : Box) is 45 | begin 46 | bc.bounding := bounding; 47 | end Set_Bounding_Box; 48 | 49 | procedure Draw (bc : in out Bar_Code; kind : Kind_Of_Code; text : String) is 50 | begin 51 | case kind is 52 | when Code_128 => Encode_Code_128.Draw (bc, text); 53 | when Code_MSI => Encode_MSI.Draw (bc, text); 54 | when Code_UPCA_EAN13 => Encode_UPCA_EAN13.Draw (bc, text, kind); 55 | when Code_DM => Encode_DM.Draw (bc, text, kind); 56 | when Code_QR => Encode_QR.Draw (bc, text, kind); 57 | end case; 58 | end Draw; 59 | 60 | function Fitting (kind : Kind_Of_Code; text : String) return Module_Box is 61 | (case kind is 62 | when Code_128 => Encode_Code_128.Fitting (text), 63 | when Code_MSI => Encode_MSI.Fitting (text), 64 | when Code_UPCA_EAN13 => Encode_UPCA_EAN13.Fitting, 65 | when Code_DM => Encode_DM.Fitting (text, kind), 66 | when Code_QR => Encode_QR.Fitting (text, kind)); 67 | 68 | function Get_Module_Width (bc : Bar_Code) return Real is (bc.module_width); 69 | function Get_Module_Height (bc : Bar_Code) return Real is (bc.module_height); 70 | 71 | procedure Output_to_Media 72 | (bc : in out Bar_Code'Class; 73 | border_size_x : in Positive; 74 | border_size_y : in Positive; 75 | module : in Grid) 76 | is 77 | done : Grid (0 .. border_size_y - 1, 0 .. border_size_x - 1) := (others => (others => False)); 78 | size_x, size_y : Positive; 79 | begin 80 | -- For vector graphics only: we want to squeeze the full 2D code 81 | -- into the bounding box. A "module" is the smallest square. 82 | bc.module_width := bc.bounding.width / Real (border_size_x); 83 | bc.module_height := bc.bounding.height / Real (border_size_y); 84 | -- 85 | for y in done'Range (1) loop 86 | for x in done'Range (2) loop 87 | if module (y, x) and then not done (y, x) then 88 | -- We search for the largest "black" rectangle starting from 89 | -- the (y, x) point. On a vector graphics output, there are 90 | -- two advantages: 91 | -- - the output is much smaller (for SVG or PDF, the file 92 | -- is typically reduced to 1/4 of the "uncompressed" size) 93 | -- - many artefacts appearing between "black" modules are 94 | -- removed; it is appearent when you zoom a SVG file 95 | -- to the max on a Web browser. 96 | size_x := 1; 97 | size_y := 1; 98 | -- Try to extend the square to the right: 99 | for xh in x + 1 .. done'Last (2) loop 100 | exit when done (y, xh) or not module (y, xh); 101 | size_x := size_x + 1; 102 | end loop; 103 | -- Try to extend the rectangle vertically: 104 | Vertical_Extension : 105 | for yv in y + 1 .. done'Last (1) loop 106 | for xt in x .. x + size_x - 1 loop 107 | exit Vertical_Extension when done (yv, xt) or not module (yv, xt); 108 | end loop; 109 | size_y := size_y + 1; 110 | end loop Vertical_Extension; 111 | Filled_Rectangle (bc, (x, border_size_y - size_y - y, size_x, size_y)); 112 | for yt in y .. y + size_y - 1 loop 113 | for xt in x .. x + size_x - 1 loop 114 | done (yt, xt) := True; 115 | end loop; 116 | end loop; 117 | end if; 118 | end loop; 119 | end loop; 120 | end Output_to_Media; 121 | 122 | ---------------------------------------------------- 123 | -- Goodies that can be useful for implementations -- 124 | ---------------------------------------------------- 125 | 126 | package RIO is new Ada.Text_IO.Float_IO (Real); 127 | 128 | -- Compact real number image, taken from PDF_Out 129 | -- 130 | function Img (x : Real; prec : Positive := Real'Digits) return String is 131 | s : String (1 .. 20 + prec); 132 | na : Natural := s'First; 133 | nb : Natural := s'Last; 134 | np : Natural := 0; 135 | begin 136 | RIO.Put (s, x, prec, 0); 137 | -- We will increase na and decrease nb 138 | -- to compact the string s (na .. nb); 139 | for i in s'Range loop 140 | case s (i) is 141 | when '.' => np := i; exit; -- Find a decimal point 142 | when ' ' => na := i + 1; -- * Trim spaces on left 143 | when others => null; 144 | end case; 145 | end loop; 146 | if np > 0 then 147 | while nb > np and then s (nb) = '0' loop 148 | nb := nb - 1; -- * Remove extra '0's after decimal point 149 | end loop; 150 | if nb = np then 151 | nb := nb - 1; -- * Remove '.' if it is at the end 152 | elsif s (na .. np - 1) = "-0" then 153 | na := na + 1; 154 | s (na) := '-'; -- * Reduce "-0.x" to "-.x" 155 | elsif s (na .. np - 1) = "0" then 156 | na := na + 1; -- * Reduce "0.x" to ".x" 157 | end if; 158 | end if; 159 | return s (na .. nb); 160 | end Img; 161 | 162 | function Make_Printable (s : String) return String is 163 | t : String := s; 164 | begin 165 | for i in s'Range loop 166 | case s (i) is 167 | when ' ' .. '~' => null; 168 | when others => t (i) := '*'; 169 | end case; 170 | end loop; 171 | return t; 172 | end Make_Printable; 173 | 174 | end Bar_Codes; 175 | -------------------------------------------------------------------------------- /bar_codes-encode_upca_ean13.adb: -------------------------------------------------------------------------------- 1 | separate (Bar_Codes) 2 | 3 | package body Encode_UPCA_EAN13 is 4 | 5 | -- Adapted from Bar_Code_Drawing: 6 | -- 7 | -- Drawing UPC-A/EAN-13 bar codes 8 | -- 9 | -- Copyright (C) by PragmAda Software Engineering 10 | -- 11 | -- Released under the terms of the 3-Clause BSD License. 12 | -- See https://opensource.org/licenses/BSD-3-Clause 13 | 14 | subtype Digit_Value is Integer range 0 .. 9; 15 | subtype Digit is Character range '0' .. '9'; 16 | 17 | function Valid (text : in String; kind : Code_UPCA_EAN13) return Boolean is 18 | ((for all C of text => C in Digit) 19 | and 20 | ((text'Length = 11 and kind = Code_UPCA) 21 | or 22 | (text'Length = 12 and kind = Code_EAN13))); 23 | 24 | function Checksum (Text : in String) return Digit_Value is 25 | subtype S11 is String (1 .. 11); 26 | S : constant S11 := Text (Text'First + (if Text'Length = 11 then 0 else 1) .. Text'Last); 27 | Sum : Natural := 0; 28 | begin 29 | for I in S'Range loop 30 | Sum := Sum + (if I rem 2 = 0 then 1 else 3) * (Character'Pos (S (I)) - Character'Pos ('0')); 31 | end loop; 32 | 33 | if Text'Length = 12 then 34 | Sum := Sum + Character'Pos (Text (Text'First)) - Character'Pos ('0'); 35 | end if; 36 | 37 | Sum := Sum rem 10; 38 | 39 | return (if Sum > 0 then 10 - Sum else Sum); 40 | end Checksum; 41 | 42 | function Checksum (Text : in String) return Digit is 43 | (Character'Val (Checksum (Text) + Character'Pos ('0'))); 44 | 45 | -- The extra digit of EAN-13 is encoded through the usage 46 | -- of two bar code sets for other digits. 47 | Code_Modules_Width : constant := 95; 48 | 49 | procedure Draw (bc : in out Bar_Code; text : String; kind : Code_UPCA_EAN13) is 50 | S : constant String (1 .. text'Length) := text; 51 | 52 | subtype Digit_Pattern is String (1 .. 7); -- Each digit takes 7 modules 53 | type Pattern_Map is array (Digit) of Digit_Pattern; 54 | 55 | Set_A_Map : constant Pattern_Map := ('0' => "0001101", -- Bar patterns for alphabet A (left half) 56 | '1' => "0011001", 57 | '2' => "0010011", 58 | '3' => "0111101", 59 | '4' => "0100011", 60 | '5' => "0110001", 61 | '6' => "0101111", 62 | '7' => "0111011", 63 | '8' => "0110111", 64 | '9' => "0001011"); 65 | Set_B_Map : constant Pattern_Map := ('0' => "0100111", -- Bar patterns for alphabet B (left half) 66 | '1' => "0110011", 67 | '2' => "0011011", 68 | '3' => "0100001", 69 | '4' => "0011101", 70 | '5' => "0111001", 71 | '6' => "0000101", 72 | '7' => "0010001", 73 | '8' => "0001001", 74 | '9' => "0010111"); 75 | Set_C_Map : constant Pattern_Map := ('0' => "1110010", -- Bar patterns for alphabet B (right half) 76 | '1' => "1100110", 77 | '2' => "1101100", 78 | '3' => "1000010", 79 | '4' => "1011100", 80 | '5' => "1001110", 81 | '6' => "1010000", 82 | '7' => "1000100", 83 | '8' => "1001000", 84 | '9' => "1110100"); 85 | End_Guard : constant String := "101"; 86 | Middle_Guard : constant String := "01010"; 87 | 88 | type A_or_B is (A, B); 89 | type EAN_A_Pattern is array (1 .. 6) of A_or_B; 90 | type EAN_Pattern_Map is array (Digit) of EAN_A_Pattern; 91 | 92 | EAN_A : constant EAN_Pattern_Map := ('0' => (A, A, A, A, A, A), 93 | '1' => (A, A, B, A, B, B), 94 | '2' => (A, A, B, B, A, B), 95 | '3' => (A, A, B, B, B, A), 96 | '4' => (A, B, A, A, B, B), 97 | '5' => (A, B, B, A, A, B), 98 | '6' => (A, B, B, B, A, A), 99 | '7' => (A, B, A, B, A, B), 100 | '8' => (A, B, A, B, B, A), 101 | '9' => (A, B, B, A, B, A)); 102 | 103 | procedure Bar (offset, width : Natural) is 104 | begin 105 | Filled_Rectangle 106 | (Bar_Code'Class (bc), -- Will use the concrete child method for displaying a rectangle 107 | (left => offset, 108 | bottom => 0, 109 | width => width, 110 | height => 1)); 111 | end Bar; 112 | 113 | X : Natural := 0; 114 | 115 | procedure Draw (Pattern : in String) is 116 | done : array (Pattern'Range) of Boolean := (others => False); 117 | j, width : Integer; 118 | begin 119 | for i in Pattern'Range loop 120 | if Pattern (i) = '1' and then not done (i) then 121 | j := i; 122 | for k in i + 1 .. Pattern'Last loop 123 | exit when Pattern (k) /= '1'; 124 | j := k; 125 | done (j) := True; 126 | end loop; 127 | width := j - i + 1; 128 | Bar (X, width); 129 | end if; 130 | X := X + 1; 131 | end loop; 132 | end Draw; 133 | 134 | Offset : constant Natural := text'Length - 11; 135 | UPC : constant Boolean := text'Length = 11; 136 | 137 | begin 138 | if not Valid (text, kind) then 139 | raise Cannot_Encode 140 | with 141 | (case kind is 142 | when Code_UPCA => "Message must be 11 decimal digits for UPC-A", 143 | when Code_EAN13 => "Message must be 12 decimal digits for EAN-13"); 144 | end if; 145 | 146 | -- For vector graphics only: we need to squeeze the full displayed code 147 | -- into the bounding box. A "module" is the thinnest bar. 148 | bc.module_width := bc.bounding.width / Real (Code_Modules_Width); 149 | bc.module_height := bc.bounding.height; -- This is a 1D code: any bar takes the full height 150 | 151 | Draw (End_Guard); 152 | 153 | Draw_Left : for I in 1 + Offset .. 6 + Offset loop 154 | Draw 155 | ((if UPC then 156 | Set_A_Map (S (I)) 157 | else 158 | (case EAN_A (S (1)) (I - Offset) is 159 | when A => Set_A_Map (S (I)), 160 | when B => Set_B_Map (S (I))))); 161 | end loop Draw_Left; 162 | 163 | Draw (Middle_Guard); 164 | 165 | Draw_Right : for I in 7 + Offset .. 11 + Offset loop 166 | Draw (Set_C_Map (S (I))); 167 | end loop Draw_Right; 168 | 169 | Draw (Set_C_Map (Checksum (text))); 170 | Draw (End_Guard); 171 | 172 | end Draw; 173 | 174 | function Fitting return Module_Box is 175 | (0, 0, Code_Modules_Width, 1); 176 | 177 | end Encode_UPCA_EAN13; 178 | -------------------------------------------------------------------------------- /bar_codes.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------------- 2 | -- 3 | -- BAR_CODES - A package for displaying bar codes (1D or 2D). 4 | -- Project name: Ada Bar Codes. 5 | -- 6 | -- Pure Ada 2005 code, 100% portable: OS-, CPU- and compiler- independent. 7 | -- 8 | -- Version / date / download info: see the version, reference, web strings 9 | -- defined at the end of the public part of this package. 10 | 11 | -- Legal licensing note: 12 | 13 | -- Copyright (c) 2018 .. 2025 Gautier de Montmollin 14 | 15 | -- Permission is hereby granted, free of charge, to any person obtaining a copy 16 | -- of this software and associated documentation files (the "Software"), to deal 17 | -- in the Software without restriction, including without limitation the rights 18 | -- to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 19 | -- copies of the Software, and to permit persons to whom the Software is 20 | -- furnished to do so, subject to the following conditions: 21 | 22 | -- The above copyright notice and this permission notice shall be included in 23 | -- all copies or substantial portions of the Software. 24 | 25 | -- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 26 | -- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 27 | -- FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 28 | -- AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 29 | -- LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 30 | -- OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 31 | -- THE SOFTWARE. 32 | 33 | -- NB: this is the MIT License, as found 12-Sep-2007 on the site 34 | -- http://www.opensource.org/licenses/mit-license.php 35 | 36 | -- (*) All Trademarks mentioned are properties of their respective owners. 37 | ------------------------------------------------------------------------------------- 38 | 39 | package Bar_Codes is 40 | 41 | type Kind_Of_Code is 42 | -- 43 | -- Code 128 is a 1D bar code that can encode the first 128 ASCII characters. 44 | -- Standard: ISO/IEC 15417:2007. 45 | -- 46 | (Code_128, 47 | -- 48 | -- MSI 1D bar codes. 49 | -- 50 | Code_MSI, 51 | -- 52 | -- UPC-A / EAN-13 are 1D bar codes used on labels of retail products. 53 | -- 54 | Code_UPCA, 55 | Code_EAN13, 56 | -- 57 | -- Data Matrix is a 2D bar code popular for marking small items. 58 | -- Standard: ISO/IEC 16022:2006 59 | -- 60 | Code_DM_Rectangular, 61 | Code_DM_Square, 62 | -- 63 | -- QR (for "Quick Response") is a popular 2D bar code. 64 | -- Standard: ISO/IEC 18004:2015. 65 | -- 66 | Code_QR_Low, -- Level L (Low) 7% of codewords can be restored. 67 | Code_QR_Medium, -- Level M (Medium) 15% of codewords can be restored. 68 | Code_QR_Quartile, -- Level Q (Quartile) 25% of codewords can be restored. 69 | Code_QR_High); -- Level H (High) 30% of codewords can be restored. 70 | 71 | -- Classify the bar codes by dimensions (1-dimensional or 2-dimensional): 72 | -- 73 | subtype Code_1D is Kind_Of_Code range Kind_Of_Code'First .. Code_EAN13; 74 | subtype Code_2D is Kind_Of_Code range Code_DM_Rectangular .. Kind_Of_Code'Last; 75 | 76 | -- Classify the bar codes by family (Data Matrix, QR, ...): 77 | -- 78 | subtype Code_DM is Kind_Of_Code range Code_DM_Rectangular .. Code_DM_Square; 79 | subtype Code_QR is Kind_Of_Code range Code_QR_Low .. Code_QR_High; 80 | subtype Code_UPCA_EAN13 is Kind_Of_Code range Code_UPCA .. Code_EAN13; 81 | 82 | function Code_2D_Square (kind : Kind_Of_Code) return Boolean is (kind in Code_DM_Square | Code_QR); 83 | 84 | type Real is digits 15; 85 | 86 | type Box is record left, bottom, width, height : Real; end record; 87 | 88 | --------------------------------------------------------------- 89 | -- Here is what you need to implement the bar code on -- 90 | -- any device. For an example, see the PDF, SVG or PBM -- 91 | -- implementations in the package `Bar_Codes_Media`. -- 92 | -- -- 93 | -- `Bar_Code` is the main type around bar code generation. -- 94 | -- The rendering of the bars is abstracted. -- 95 | --------------------------------------------------------------- 96 | 97 | type Bar_Code is abstract tagged private; 98 | 99 | -- `Set_Bounding_Box` is meaningful only for a vector graphics implementation 100 | -- such as PDF or SVG (see those implementations in `Bar_Codes_Media` to see why). 101 | -- 102 | procedure Set_Bounding_Box (bc : in out Bar_Code; bounding : Box); 103 | 104 | procedure Draw (bc : in out Bar_Code; kind : Kind_Of_Code; text : String); 105 | 106 | --------------- 107 | -- Modules -- 108 | --------------- 109 | 110 | -- A "module" is the thinnest bar (1D), or the smallest box (2D). 111 | -- The coordinates of a Module_Box are in "module" units. 112 | -- This is practical for raster graphics (typically on a screen) since the 113 | -- display can be done on a multiple of those units without rounding errors. 114 | -- 115 | type Module_Box is record left, bottom, width, height : Natural; end record; 116 | 117 | -- The `Fitting` function will return the exact box, in terms of modules, needed 118 | -- to fit the bar code for a given text. Fitting.left = Fitting.bottom = 0. 119 | -- For 1D codes Fitting.height = 1. 120 | -- This function is helpful to calibrate a raster graphics bitmap. 121 | -- 122 | function Fitting (kind : Kind_Of_Code; text : String) return Module_Box; 123 | 124 | function Get_Module_Width (bc : Bar_Code) return Real; 125 | function Get_Module_Height (bc : Bar_Code) return Real; 126 | 127 | -- Callback method for filling a black bar (on PDF, SVG, etc.). 128 | -- For raster graphics, the shape parameter can be used for pixel coordinates 129 | -- or possibly integer multiples of them. If multiples were not integers, 130 | -- the bar codes would be wrong on raster graphics. 131 | -- 132 | procedure Filled_Rectangle (bc : Bar_Code; shape : Module_Box) is abstract; 133 | 134 | Cannot_Encode : exception; 135 | 136 | ------------------------------------------------------ 137 | -- Goodies that can be useful for implementations -- 138 | ------------------------------------------------------ 139 | 140 | -- Compact real number image 141 | function Img (x : Real; prec : Positive := Real'Digits) return String; 142 | 143 | -- Display a string (assumed 7-bit), with non-printable 144 | -- characters replaced by '*'. 145 | function Make_Printable (s : String) return String; 146 | 147 | ---------------------------------------------------------------- 148 | -- Information about this package - e.g. for an "about" box -- 149 | ---------------------------------------------------------------- 150 | 151 | title : constant String := "Ada Bar Codes"; 152 | version : constant String := "006"; 153 | reference : constant String := "06-Dec-2025"; 154 | -- Hopefully the latest version is reachable at one of those URLs: 155 | web : constant String := "http://ada-bar-codes.sf.net/"; 156 | web2 : constant String := "https://sourceforge.net/projects/ada-bar-codes/"; 157 | web3 : constant String := "https://github.com/zertovitch/ada-bar-codescra"; 158 | web4 : constant String := "https://alire.ada.dev/crates/bar_codes"; 159 | 160 | private 161 | 162 | type Bar_Code is abstract tagged record 163 | bounding : Box := (0.0, 0.0, 1.0, 1.0); 164 | module_width : Real; 165 | module_height : Real; 166 | end record; 167 | 168 | -- Facilities for 2D bar codes 169 | 170 | type Grid is array (Natural range <>, Natural range <>) of Boolean; 171 | 172 | procedure Output_to_Media 173 | (bc : in out Bar_Code'Class; 174 | border_size_x : in Positive; 175 | border_size_y : in Positive; 176 | module : in Grid); 177 | 178 | verbosity_level : constant Natural := 0; 179 | 180 | -- Controls diagnostic/debug output during all operations. 181 | -- 182 | -- 0: no output 183 | -- 1: some output 184 | -- > 1: more output 185 | 186 | end Bar_Codes; 187 | -------------------------------------------------------------------------------- /bar_codes-encode_code_128.adb: -------------------------------------------------------------------------------- 1 | with Ada.Text_IO; 2 | 3 | -- Nice to have: find optimal code. 4 | 5 | separate (Bar_Codes) 6 | 7 | package body Encode_Code_128 is 8 | 9 | -- See bc_work.xls, sheet: Code_128 10 | 11 | subtype Code_Range is Integer range 0 .. 106; 12 | 13 | type Sequence is array (Positive range <>) of Code_Range; 14 | 15 | function Compose_Code (text : String) return Sequence is 16 | -- Worst case: we switch subcode for each symbol! 17 | max_length : constant Integer := text'Length * 2 + 2; 18 | code : Sequence (1 .. max_length); 19 | code_length : Natural := 0; 20 | -- 21 | type Code_128_subcode is (undefined, A, B, C); 22 | subcode : Code_128_subcode := undefined; 23 | checksum : Natural := 0; 24 | -- 25 | procedure Add_symbol (symbol : Code_Range) is 26 | begin 27 | checksum := checksum + symbol * Integer'Max (1, code_length); 28 | code_length := code_length + 1; 29 | code (code_length) := symbol; 30 | end Add_symbol; 31 | -- 32 | subtype Defined_subcode is Code_128_subcode range A .. C; 33 | -- 34 | first_digit : Boolean; -- First digit in a pair of digits for subcode C 35 | -- 36 | procedure Switch_to (new_subcode : Defined_subcode) is 37 | begin 38 | if subcode = undefined then 39 | -- Start code A/B/C: 40 | case new_subcode is 41 | when A => Add_symbol (103); 42 | when B => Add_symbol (104); 43 | when C => Add_symbol (105); 44 | end case; 45 | else 46 | case new_subcode is 47 | when A => Add_symbol (101); 48 | when B => Add_symbol (100); 49 | when C => Add_symbol (099); 50 | end case; 51 | end if; 52 | if new_subcode = C then 53 | first_digit := True; 54 | end if; 55 | subcode := new_subcode; 56 | if verbosity_level > 0 then 57 | Ada.Text_IO.Put_Line ("[Code 128] switched to subcode " & subcode'Image); 58 | end if; 59 | end Switch_to; 60 | -- 61 | digit_buffer : Code_Range; 62 | digit : Integer range 0 .. 9; 63 | begin 64 | for i in text'Range loop 65 | -- Choice of a subcode 66 | case text (i) is 67 | when Character'Val (128) .. Character'Last => 68 | raise Cannot_Encode with "Message must bit 7-bit ASCII"; 69 | when ASCII.NUL .. ASCII.US => 70 | if subcode /= A then 71 | Switch_to (A); 72 | end if; 73 | when Character'Val (96) .. ASCII.DEL => 74 | if subcode /= B then 75 | Switch_to (B); 76 | end if; 77 | when '0' .. '9' => 78 | if subcode = C then 79 | -- If text (i) is meant to be the first digit of a pair, 80 | -- ensure there is a second digit after. 81 | if first_digit then 82 | if i = text'Last or else text (i + 1) not in '0' .. '9' then 83 | Switch_to (B); -- We need to encode this digit with subcode A or B 84 | end if; 85 | end if; 86 | else 87 | if i + 3 <= text'Last and then (for all j in i + 1 .. i + 3 => text (j) in '0' .. '9') then 88 | Switch_to (C); 89 | end if; 90 | if subcode = undefined then 91 | Switch_to (B); 92 | end if; 93 | end if; 94 | when others => 95 | -- A or B is good. 96 | if subcode not in A .. B then 97 | Switch_to (B); -- Just an assumption: characters like 'a' .. 'z' more likely. 98 | end if; 99 | end case; 100 | -- Encode text (i) 101 | case subcode is 102 | when undefined => null; 103 | when A => 104 | if text (i) <= ASCII.US then 105 | Add_symbol (Character'Pos (text (i)) + 64); 106 | else 107 | Add_symbol (Character'Pos (text (i)) - 32); 108 | end if; 109 | when B => 110 | Add_symbol (Character'Pos (text (i)) - 32); 111 | when C => 112 | digit := Character'Pos (text (i)) - Character'Pos ('0'); 113 | if first_digit then 114 | digit_buffer := digit; 115 | else 116 | Add_symbol (10 * digit_buffer + digit); 117 | end if; 118 | first_digit := not first_digit; 119 | end case; 120 | end loop; 121 | -- Checksum symbol 122 | Add_symbol (checksum mod 103); 123 | -- Stop symbol 124 | Add_symbol (106); 125 | -- 126 | return code (1 .. code_length); 127 | end Compose_Code; 128 | 129 | -- Here begins the graphics part. 130 | -- Each symbol drawn as a succession of bar, space, bar, space, bar, space. 131 | 132 | symbol_width : constant := 11; -- Each symbol has 3 bars and takes 11 "modules" in total. 133 | stop_extra_width : constant := 2; -- Supplemental bar after stop symbol. 134 | 135 | procedure Draw (bc : in out Bar_Code; text : String) is 136 | code : constant Sequence := Compose_Code (text); 137 | -- 138 | type Width_Sequence is array (1 .. 5) of Positive; 139 | widths : constant array (Code_Range) of Width_Sequence := 140 | -- These are the widths for: bar, space, bar, space, bar (last space width is implicit). 141 | ( 142 | 0 => (2, 1, 2, 2, 2), 143 | 1 => (2, 2, 2, 1, 2), 144 | 2 => (2, 2, 2, 2, 2), 145 | 3 => (1, 2, 1, 2, 2), 146 | 4 => (1, 2, 1, 3, 2), 147 | 5 => (1, 3, 1, 2, 2), 148 | 6 => (1, 2, 2, 2, 1), 149 | 7 => (1, 2, 2, 3, 1), 150 | 8 => (1, 3, 2, 2, 1), 151 | 9 => (2, 2, 1, 2, 1), 152 | 10 => (2, 2, 1, 3, 1), 153 | 11 => (2, 3, 1, 2, 1), 154 | 12 => (1, 1, 2, 2, 3), 155 | 13 => (1, 2, 2, 1, 3), 156 | 14 => (1, 2, 2, 2, 3), 157 | 15 => (1, 1, 3, 2, 2), 158 | 16 => (1, 2, 3, 1, 2), 159 | 17 => (1, 2, 3, 2, 2), 160 | 18 => (2, 2, 3, 2, 1), 161 | 19 => (2, 2, 1, 1, 3), 162 | 20 => (2, 2, 1, 2, 3), 163 | 21 => (2, 1, 3, 2, 1), 164 | 22 => (2, 2, 3, 1, 1), 165 | 23 => (3, 1, 2, 1, 3), 166 | 24 => (3, 1, 1, 2, 2), 167 | 25 => (3, 2, 1, 1, 2), 168 | 26 => (3, 2, 1, 2, 2), 169 | 27 => (3, 1, 2, 2, 1), 170 | 28 => (3, 2, 2, 1, 1), 171 | 29 => (3, 2, 2, 2, 1), 172 | 30 => (2, 1, 2, 1, 2), 173 | 31 => (2, 1, 2, 3, 2), 174 | 32 => (2, 3, 2, 1, 2), 175 | 33 => (1, 1, 1, 3, 2), 176 | 34 => (1, 3, 1, 1, 2), 177 | 35 => (1, 3, 1, 3, 2), 178 | 36 => (1, 1, 2, 3, 1), 179 | 37 => (1, 3, 2, 1, 1), 180 | 38 => (1, 3, 2, 3, 1), 181 | 39 => (2, 1, 1, 3, 1), 182 | 40 => (2, 3, 1, 1, 1), 183 | 41 => (2, 3, 1, 3, 1), 184 | 42 => (1, 1, 2, 1, 3), 185 | 43 => (1, 1, 2, 3, 3), 186 | 44 => (1, 3, 2, 1, 3), 187 | 45 => (1, 1, 3, 1, 2), 188 | 46 => (1, 1, 3, 3, 2), 189 | 47 => (1, 3, 3, 1, 2), 190 | 48 => (3, 1, 3, 1, 2), 191 | 49 => (2, 1, 1, 3, 3), 192 | 50 => (2, 3, 1, 1, 3), 193 | 51 => (2, 1, 3, 1, 1), 194 | 52 => (2, 1, 3, 3, 1), 195 | 53 => (2, 1, 3, 1, 3), 196 | 54 => (3, 1, 1, 1, 2), 197 | 55 => (3, 1, 1, 3, 2), 198 | 56 => (3, 3, 1, 1, 2), 199 | 57 => (3, 1, 2, 1, 1), 200 | 58 => (3, 1, 2, 3, 1), 201 | 59 => (3, 3, 2, 1, 1), 202 | 60 => (3, 1, 4, 1, 1), 203 | 61 => (2, 2, 1, 4, 1), 204 | 62 => (4, 3, 1, 1, 1), 205 | 63 => (1, 1, 1, 2, 2), 206 | 64 => (1, 1, 1, 4, 2), 207 | 65 => (1, 2, 1, 1, 2), 208 | 66 => (1, 2, 1, 4, 2), 209 | 67 => (1, 4, 1, 1, 2), 210 | 68 => (1, 4, 1, 2, 2), 211 | 69 => (1, 1, 2, 2, 1), 212 | 70 => (1, 1, 2, 4, 1), 213 | 71 => (1, 2, 2, 1, 1), 214 | 72 => (1, 2, 2, 4, 1), 215 | 73 => (1, 4, 2, 1, 1), 216 | 74 => (1, 4, 2, 2, 1), 217 | 75 => (2, 4, 1, 2, 1), 218 | 76 => (2, 2, 1, 1, 1), 219 | 77 => (4, 1, 3, 1, 1), 220 | 78 => (2, 4, 1, 1, 1), 221 | 79 => (1, 3, 4, 1, 1), 222 | 80 => (1, 1, 1, 2, 4), 223 | 81 => (1, 2, 1, 1, 4), 224 | 82 => (1, 2, 1, 2, 4), 225 | 83 => (1, 1, 4, 2, 1), 226 | 84 => (1, 2, 4, 1, 1), 227 | 85 => (1, 2, 4, 2, 1), 228 | 86 => (4, 1, 1, 2, 1), 229 | 87 => (4, 2, 1, 1, 1), 230 | 88 => (4, 2, 1, 2, 1), 231 | 89 => (2, 1, 2, 1, 4), 232 | 90 => (2, 1, 4, 1, 2), 233 | 91 => (4, 1, 2, 1, 2), 234 | 92 => (1, 1, 1, 1, 4), 235 | 93 => (1, 1, 1, 3, 4), 236 | 94 => (1, 3, 1, 1, 4), 237 | 95 => (1, 1, 4, 1, 1), 238 | 96 => (1, 1, 4, 3, 1), 239 | 97 => (4, 1, 1, 1, 1), 240 | 98 => (4, 1, 1, 3, 1), 241 | 99 => (1, 1, 3, 1, 4), 242 | 100 => (1, 1, 4, 1, 3), 243 | 101 => (3, 1, 1, 1, 4), 244 | 102 => (4, 1, 1, 1, 3), 245 | 103 => (2, 1, 1, 4, 1), 246 | 104 => (2, 1, 1, 2, 1), 247 | 105 => (2, 1, 1, 2, 3), 248 | 106 => (2, 3, 3, 1, 1) 249 | ); 250 | x : Natural := 0; 251 | -- 252 | procedure Bar (width : Natural) is 253 | begin 254 | Filled_Rectangle 255 | (Bar_Code'Class (bc), -- Will use the concrete child method for displaying a rectangle 256 | (left => x, 257 | bottom => 0, 258 | width => width, 259 | height => 1)); 260 | end Bar; 261 | begin 262 | -- For vector graphics only: we need to squeeze the full displayed code 263 | -- into the bounding box. A "module" is the thinnest bar. 264 | bc.module_width := bc.bounding.width / Real (code'Length * symbol_width + stop_extra_width); 265 | bc.module_height := bc.bounding.height; -- This is a 1D code: any bar takes the full height 266 | -- 267 | for i in code'Range loop 268 | declare 269 | ws : Width_Sequence renames widths (code (i)); 270 | begin 271 | Bar (ws (1)); 272 | x := x + ws (1) + ws (2); 273 | Bar (ws (3)); 274 | x := x + ws (3) + ws (4); 275 | Bar (ws (5)); 276 | -- x := x + ws (5) + implicit ws (6). 277 | x := (i - code'First + 1) * symbol_width; 278 | end; 279 | end loop; 280 | -- Extra bar after the Stop symbol; this gives the Reverse Stop symbol 281 | -- when the bar code is scanned turned 180 degrees. 282 | Bar (stop_extra_width); 283 | end Draw; 284 | 285 | function Fitting (text : String) return Module_Box is 286 | (0, 0, Compose_Code (text)'Length * symbol_width + stop_extra_width, 1); 287 | 288 | end Encode_Code_128; 289 | -------------------------------------------------------------------------------- /bar_codes-encode_dm.adb: -------------------------------------------------------------------------------- 1 | with Ada.Containers.Vectors; 2 | with Ada.Text_IO; 3 | 4 | separate (Bar_Codes) 5 | 6 | package body Encode_DM is 7 | 8 | type Byte is mod 256; 9 | 10 | package Byte_Vectors is new Ada.Containers.Vectors (Natural, Byte); 11 | subtype Byte_Vector is Byte_Vectors.Vector; 12 | 13 | -- Translated (and later improved) from datamatrix.js: 14 | -- 15 | -- https://github.com/datalog/datamatrix-svg 16 | -- under MIT license 17 | -- datamatrix.js has no dependencies 18 | -- Copyright (c) 2020 Constantine 19 | 20 | escape_switch_base_256 : constant := 231; 21 | escape_upper_shift : constant := 235; 22 | 23 | function To_ASCII (text : String) return Byte_Vector is 24 | -- The "ASCII" encoding is more efficient for 7-bit 25 | -- values and pairs of digits. 26 | r : Byte_Vector; 27 | i : Positive := text'First; 28 | c, c1 : Byte; 29 | begin 30 | 31 | while i <= text'Last loop 32 | c := Character'Pos (text (i)); 33 | c1 := (if i + 1 <= text'Last then Character'Pos (text (i + 1)) else 0); 34 | if c in 48 .. 57 and then c1 in 48 .. 57 then 35 | -- Two consecutive digits. 36 | r.Append ((c - 48) * 10 + c1 - 48 + 130); -- Codes 130 .. 229 are used for "00" .. "99". 37 | i := i + 1; 38 | elsif c > 127 then 39 | r.Append (escape_upper_shift); 40 | r.Append ((c - 127) and 255); 41 | else 42 | r.Append (c + 1); 43 | end if; 44 | i := i + 1; 45 | end loop; 46 | 47 | return r; 48 | end To_ASCII; 49 | 50 | base_256_limit : constant := (255 - 37) * 250 + 249; 51 | 52 | function To_Base_256 (text : String) return Byte_Vector is 53 | -- The "BASE-256" encoding is aimed at binary data. 54 | r : Byte_Vector; 55 | use type Ada.Containers.Count_Type; 56 | begin 57 | if text'Length > base_256_limit then 58 | raise Cannot_Encode with "Message to be encoded is too long for the Base-256 method"; 59 | end if; 60 | 61 | r.Append (escape_switch_base_256); 62 | 63 | if text'Length > 250 then 64 | -- Length high byte (in 255-state algo): 65 | r.Append (Byte (Integer'(37) + (text'Length / 250) rem 256)); 66 | end if; 67 | 68 | -- Length low byte (in 255-state algo): 69 | r.Append (Byte (Integer'(text'Length rem 250 + 149 * Integer (r.Length + 1) rem 255 + 1) rem 256)); 70 | 71 | for ch of text loop 72 | r.Append (Byte (Integer'(Character'Pos (ch) + 149 * Integer (r.Length + 1) rem 255 + 1) rem 256)); 73 | end loop; 74 | 75 | return r; 76 | end To_Base_256; 77 | 78 | function To_DM_Bytes (t : String) return Byte_Vector is 79 | candidate, challenger : Byte_Vector; 80 | use Ada.Text_IO; 81 | use type Ada.Containers.Count_Type; 82 | begin 83 | candidate := To_ASCII (t); 84 | if verbosity_level > 0 then 85 | Put ("Data Matrix: text length:" & t'Length'Image); 86 | if verbosity_level > 1 then 87 | Put (", [" & t & ']'); 88 | end if; 89 | New_Line; 90 | Put_Line ("Data Matrix: chosen encoding so far: ""ASCII"", length:" & candidate.Length'Image); 91 | end if; 92 | 93 | if t'Length <= base_256_limit then 94 | challenger := To_Base_256 (t); 95 | if challenger.Length < candidate.Length then 96 | candidate := challenger; 97 | if verbosity_level > 0 then 98 | Put_Line ("Data Matrix: chosen encoding so far: ""Base_256"", length:" & candidate.Length'Image); 99 | end if; 100 | end if; 101 | end if; 102 | 103 | return candidate; 104 | -- !! TBD: try other encodings: Edifact, ... (done in datamatrix.js). 105 | end To_DM_Bytes; 106 | 107 | type U16 is mod 2**16; 108 | 109 | procedure Calibrate_Rectangular 110 | (byte_count_message : in Natural; 111 | nr, nc, blocks, width, height, byte_count_symbol, rscw : out Natural) 112 | is 113 | type Size_Range is range 0 .. 5; 114 | symbol_width : constant array (Size_Range) of Integer := (16, 28, 24, 32, 32, 44); 115 | symbol_height : constant array (Size_Range) of Integer := (6, 6, 10, 10, 14, 14); 116 | rs_checkwords : constant array (Size_Range) of Integer := (7, 11, 14, 18, 24, 28); 117 | begin 118 | for j in Size_Range loop 119 | width := symbol_width (j); 120 | height := symbol_height (j); 121 | byte_count_symbol := width * height / 8; 122 | rscw := rs_checkwords (j); 123 | exit when byte_count_symbol >= byte_count_message + rscw; 124 | end loop; 125 | -- Regions: 126 | nr := 1; 127 | nc := (if width > 25 then 2 else 1); 128 | blocks := 1; 129 | end Calibrate_Rectangular; 130 | 131 | procedure Calibrate_Square 132 | (byte_count_message : in Natural; 133 | nr, nc, blocks, width, height, byte_count_symbol, rscw : out Natural) 134 | is 135 | rs_checkwords : constant array (0 .. 23) of Integer := 136 | (5, 7, 10, 12, 14, 18, 20, 24, 28, 36, 42, 48, 56, 68, 84, 112, 144, 192, 224, 272, 336, 408, 496, 620); 137 | size_increment : Integer := 2; 138 | begin 139 | width := 6; 140 | height := 6; 141 | for j in rs_checkwords'Range loop 142 | if width > 11 * size_increment then 143 | size_increment := 4 + Integer (U16 (size_increment) and 12); -- Advance increment 144 | end if; 145 | width := width + size_increment; 146 | height := height + size_increment; 147 | byte_count_symbol := width * height / 8; 148 | rscw := rs_checkwords (j); 149 | exit when byte_count_symbol >= byte_count_message + rscw; 150 | if j = rs_checkwords'Last then 151 | raise Cannot_Encode with "Message to be encoded doesn't fit in any Data Matrix size"; 152 | end if; 153 | end loop; 154 | -- Regions: 155 | nr := (if width > 27 then 2 * (width / 54) + 2 else 1); 156 | nc := nr; 157 | blocks := (if byte_count_symbol > 255 then 2 * (byte_count_symbol / 512) + 2 else 1); 158 | end Calibrate_Square; 159 | 160 | procedure Calibrate 161 | (byte_count_message : in Natural; 162 | want_rectangular : in Boolean; 163 | nr, nc, blocks, width, height, byte_count_symbol, rscw : out Natural) 164 | is 165 | begin 166 | if want_rectangular and then byte_count_message < 50 then 167 | Calibrate_Rectangular 168 | (byte_count_message, nr, nc, blocks, width, height, byte_count_symbol, rscw); 169 | else 170 | Calibrate_Square 171 | (byte_count_message, nr, nc, blocks, width, height, byte_count_symbol, rscw); 172 | end if; 173 | end Calibrate; 174 | 175 | ---------- 176 | -- Draw -- 177 | ---------- 178 | 179 | procedure Draw (bc : in out Bar_Code; text : String; dm_kind : Code_DM) is 180 | want_rectangular : constant Boolean := dm_kind = Code_DM_Rectangular; 181 | enc : Byte_Vector := To_DM_Bytes (text); 182 | height, width : Integer; 183 | nc, nr : Integer; 184 | fw, fh : Integer; 185 | border_size_x, border_size_y : Natural := 0; 186 | 187 | max_size : constant := 144; 188 | 189 | module : Grid (0 .. max_size - 1, 0 .. max_size - 1) := (others => (others => False)); 190 | 191 | procedure bit (x, y : Integer) is 192 | begin 193 | module (y, x) := True; 194 | border_size_x := Integer'Max (border_size_x, x + 1); 195 | border_size_y := Integer'Max (border_size_y, y + 1); 196 | end bit; 197 | 198 | procedure Preparation is 199 | el : Natural := Natural (enc.Length); 200 | rs : array (0 .. 69) of Byte := (others => 0); -- Reed / Solomon code 201 | rc : array (0 .. 69) of Byte := (others => 0); 202 | log : array (0 .. 255) of Integer := (others => 0); -- log / exp table for multiplication 203 | exp : array (0 .. 254) of Integer := (others => 0); 204 | i, exp_i, l : Integer; 205 | s : Integer; 206 | blocks : Integer; 207 | x : Byte; 208 | rc_index : Natural; 209 | use Ada.Text_IO; 210 | begin 211 | Calibrate (el, want_rectangular, nr, nc, blocks, width, height, l, s); 212 | 213 | -- Region size 214 | fw := width / nc; 215 | fh := height / nr; 216 | 217 | -- First padding 218 | if el < l - s then 219 | el := el + 1; 220 | enc.Append (129); 221 | end if; 222 | 223 | -- More padding 224 | while el < l - s loop 225 | el := el + 1; 226 | enc.Append (Byte ((((149 * el) rem 253) + 130) rem 254)); 227 | -- Put_Line ("DM: more padding"); 228 | end loop; 229 | 230 | -- Reed Solomon error detection and correction 231 | s := s / blocks; 232 | 233 | exp_i := 1; 234 | -- log / exp table of Galois field 235 | for i in exp'Range loop 236 | exp (i) := exp_i; 237 | log (exp_i) := i; 238 | exp_i := exp_i + exp_i; 239 | if exp_i > 255 then 240 | exp_i := Integer ((U16 (exp_i) xor 301)); 241 | -- "301 = a^8 + a^5 + a^3 + a^2 + 1" 242 | end if; 243 | end loop; 244 | 245 | -- RS generator polynomial 246 | rs (s) := 0; 247 | for i in 1 .. s loop 248 | rs (s - i) := 1; 249 | for j in s - i .. s - 1 loop 250 | rs (j) := rs (j + 1) xor Byte (exp ((log (Integer (rs (j))) + i) rem 255)); 251 | end loop; 252 | end loop; 253 | 254 | -- RS correction data for each block 255 | for c in 0 .. blocks - 1 loop 256 | rc (0 .. s) := (others => 0); 257 | i := c; 258 | while i < el loop 259 | x := rc (0) xor enc (i); 260 | for j in 0 .. s - 1 loop 261 | rc (j) := rc (j + 1) xor Byte (if x /= 0 then exp ((log (Integer (rs (j))) + log (Integer (x))) rem 255) else 0); 262 | end loop; 263 | i := i + blocks; 264 | end loop; 265 | -- Interleaved correction data 266 | for i in 0 .. s - 1 loop 267 | rc_index := el + c + i * blocks; 268 | while enc.Last_Index < rc_index loop 269 | enc.Append (0); 270 | end loop; 271 | enc (rc_index) := rc (i); 272 | end loop; 273 | end loop; 274 | if verbosity_level > 1 then 275 | Put_Line ("DM: byte sequence including ECC:"); 276 | for elem of enc loop 277 | Put_Line (elem'Image); 278 | end loop; 279 | end if; 280 | end Preparation; 281 | 282 | procedure Horizontal_Layout_Perimeter_Finder_Pattern is 283 | i : Integer := 0; 284 | begin 285 | while i < height + 2 * nr loop 286 | for j in 0 .. width + 2 * nc - 1 loop 287 | bit (j, i + fh + 1); 288 | if j rem 2 = 0 then 289 | bit (j, i); 290 | end if; 291 | end loop; 292 | i := i + fh + 2; 293 | end loop; 294 | end Horizontal_Layout_Perimeter_Finder_Pattern; 295 | 296 | procedure Vertical_Layout_Perimeter_Finder_Pattern is 297 | i : Integer := 0; 298 | begin 299 | while i < width + 2 * nc loop 300 | for j in 0 .. height - 1 loop 301 | bit (i, j + (j / fh) * 2 + 1); 302 | if j rem 2 = 1 then 303 | bit (i + fw + 1, j + (j / fh) * 2); 304 | end if; 305 | end loop; 306 | i := i + fw + 2; 307 | end loop; 308 | end Vertical_Layout_Perimeter_Finder_Pattern; 309 | 310 | procedure Draw_Data is 311 | step : Integer := 2; 312 | col : Integer := 0; 313 | row : Integer := 4; 314 | 315 | type Offset is record 316 | x, y : Integer; 317 | end record; 318 | 319 | type Layout_Type is array (0 .. 7) of Offset; 320 | 321 | -- Nominal layout (L-shaped) for displaying a byte: 322 | normal : constant Layout_Type := 323 | ((0, 0), 324 | (-1, 0), 325 | (-2, 0), 326 | (0, -1), 327 | (-1, -1), 328 | (-2, -1), 329 | (-1, -2), 330 | (-2, -2)); 331 | 332 | layout : Layout_Type; 333 | draw_it : Boolean; 334 | el : Byte; 335 | x, y : Integer; 336 | 337 | procedure Check_Corners is 338 | begin 339 | if row = height - 3 and then col = -1 then 340 | -- Corner A layout 341 | layout := 342 | ((width, 6 - height), 343 | (width, 5 - height), 344 | (width, 4 - height), 345 | (width, 3 - height), 346 | (width - 1, 3 - height), 347 | (3, 2), 348 | (2, 2), 349 | (1, 2)); 350 | elsif row = height + 1 and then col = 1 and then width rem 8 = 0 and then height rem 8 = 6 then 351 | -- Corner D layout 352 | layout := 353 | ((width - 2, -height), 354 | (width - 3, -height), 355 | (width - 4, -height), 356 | (width - 2, -1 - height), 357 | (width - 3, -1 - height), 358 | (width - 4, -1 - height), 359 | (width - 2, -2), 360 | (-1, -2)); 361 | elsif row = 0 and then col = width - 2 and then width rem 4 /= 0 then 362 | -- Corner B: omit upper left. 363 | draw_it := False; 364 | else 365 | if row not in 0 .. height - 1 or else col not in 0 .. width - 1 then 366 | -- We are outside. 367 | step := -step; -- Turn around 368 | row := row + 2 + step / 2; 369 | col := col + 2 - step / 2; 370 | 371 | while row not in 0 .. height - 1 or else col not in 0 .. width - 1 loop 372 | row := row - step; 373 | col := col + step; 374 | end loop; 375 | end if; 376 | if row = height - 2 and then col = 0 and then width rem 4 /= 0 then 377 | layout := -- Corner B layout 378 | ((width - 1, 3 - height), 379 | (width - 1, 2 - height), 380 | (width - 2, 2 - height), 381 | (width - 3, 2 - height), 382 | (width - 4, 2 - height), 383 | (0, 1), 384 | (0, 0), 385 | (0, -1)); 386 | 387 | elsif row = height - 2 and then col = 0 and then width rem 8 = 4 then 388 | layout := -- Corner C layout 389 | ((width - 1, 5 - height), 390 | (width - 1, 4 - height), 391 | (width - 1, 3 - height), 392 | (width - 1, 2 - height), 393 | (width - 2, 2 - height), 394 | (0, 1), 395 | (0, 0), 396 | (0, -1)); 397 | elsif row = 1 and then col = width - 1 and then (width rem 8) = 0 and then (height rem 8) = 6 then 398 | -- Omit corner D 399 | draw_it := False; 400 | else 401 | layout := normal; 402 | end if; 403 | end if; 404 | end Check_Corners; 405 | 406 | begin 407 | for elem of enc loop 408 | loop 409 | draw_it := True; 410 | Check_Corners; 411 | exit when draw_it; 412 | -- Diagonal steps (nothing drawn): 413 | row := row - step; 414 | col := col + step; 415 | end loop; 416 | 417 | el := elem; 418 | for j in Layout_Type'Range loop 419 | if (el and 1) /= 0 then 420 | x := col + layout (j).x; 421 | y := row + layout (j).y; 422 | 423 | -- Wrap around: 424 | if x < 0 then 425 | x := x + width; 426 | y := y + 4 - ((width + 4) rem 8); 427 | end if; 428 | if y < 0 then 429 | x := x + 4 - ((height + 4) rem 8); 430 | y := y + height; 431 | end if; 432 | 433 | -- Plot at (x, y), plus region gap 434 | bit (x + 2 * (x / fw) + 1, 435 | y + 2 * (y / fh) + 1); 436 | end if; 437 | 438 | el := el / 2; 439 | end loop; 440 | 441 | -- Diagonal steps (byte `elem` was drawn): 442 | row := row - step; 443 | col := col + step; 444 | end loop; 445 | 446 | -- Unfilled corner: 447 | for i in reverse 0 .. width loop 448 | exit when i rem 4 = 0; 449 | bit (i, i); 450 | end loop; 451 | 452 | end Draw_Data; 453 | 454 | begin 455 | Preparation; 456 | Horizontal_Layout_Perimeter_Finder_Pattern; 457 | Vertical_Layout_Perimeter_Finder_Pattern; 458 | Draw_Data; 459 | Output_to_Media (bc, border_size_x, border_size_y, module); 460 | end Draw; 461 | 462 | ------------- 463 | -- Fitting -- 464 | ------------- 465 | 466 | function Fitting (text : String; dm_kind : Code_DM) return Module_Box is 467 | want_rectangular : constant Boolean := dm_kind = Code_DM_Rectangular; 468 | enc : constant Byte_Vector := To_DM_Bytes (text); 469 | el : constant Natural := Natural (enc.Length); 470 | h, w : Integer; 471 | nc, nr : Integer; 472 | l : Integer; 473 | s : Integer; 474 | b : Integer; 475 | xx, yy : Integer; 476 | begin 477 | Calibrate (el, want_rectangular, nr, nc, b, w, h, l, s); 478 | xx := w + 2 * nc; 479 | yy := h + 2 * nr; 480 | return (0, 0, xx, yy); 481 | end Fitting; 482 | 483 | end Encode_DM; 484 | -------------------------------------------------------------------------------- /bar_codes_media.adb: -------------------------------------------------------------------------------- 1 | with Ada.Strings.Unbounded; 2 | with Ada.Unchecked_Deallocation; 3 | with Interfaces; 4 | 5 | package body Bar_Codes_Media is 6 | 7 | -------------------- 8 | -- PDF_Bar_Code -- 9 | -------------------- 10 | 11 | function PDF_Bar_Code 12 | (kind : Bar_Codes.Kind_Of_Code; 13 | bounding : Bar_Codes.Box; -- Box in the PDF page, containing the bar code 14 | text : String) -- Text to encode 15 | return String 16 | is 17 | use Ada.Strings.Unbounded, Bar_Codes; 18 | pdf_code : Unbounded_String; 19 | -- 20 | type PDF_BC is new Bar_Code with null record; 21 | -- 22 | overriding procedure Filled_Rectangle (bc : PDF_BC; shape : Module_Box) is 23 | begin 24 | pdf_code := pdf_code & 25 | " " & 26 | Img (bounding.left + bc.Get_Module_Width * Real (shape.left)) & ' ' & 27 | Img (bounding.bottom + bc.Get_Module_Height * Real (shape.bottom)) & ' ' & 28 | Img (bc.Get_Module_Width * Real (shape.width)) & ' ' & 29 | Img (bc.Get_Module_Height * Real (shape.height)) & " re" & ASCII.LF; 30 | end Filled_Rectangle; 31 | -- 32 | bc : PDF_BC; 33 | begin 34 | bc.Set_Bounding_Box (bounding); 35 | bc.Draw (kind, text); 36 | return 37 | "% Begin of Bar Code" & ASCII.LF & 38 | "% Automatically generated by " & Bar_Codes.title & 39 | " version " & Bar_Codes.version & 40 | ", " & Bar_Codes.reference & ASCII.LF & 41 | "% Web: " & Bar_Codes.web & ASCII.LF & 42 | "% Requested bar code format: " & kind'Image & ASCII.LF & 43 | "% Text to be encoded: [" & Make_Printable (text) & ']' & ASCII.LF & 44 | "% This PDF snippet has to be included into a PDF document." & ASCII.LF & 45 | "% For instance, use Insert_Graphics_PDF_Code of PDF_Out, http://apdf.sf.net/" & ASCII.LF & 46 | "q" & ASCII.LF & -- Save the current graphics state 47 | "0 g" & ASCII.LF & -- Black 48 | To_String (pdf_code) & 49 | "f" & ASCII.LF & -- Paint the rectangles (fill) 50 | "Q" & ASCII.LF & -- Restore the graphics state 51 | "% End of Bar Code" & ASCII.LF; 52 | end PDF_Bar_Code; 53 | 54 | -------------------- 55 | -- SVG_Bar_Code -- 56 | -------------------- 57 | 58 | function SVG_Bar_Code 59 | (kind : Bar_Codes.Kind_Of_Code; 60 | bounding : Bar_Codes.Box; -- Box in the SVG plane, containing the bar code 61 | unit : String; -- Length unit, for instance "mm" for millimeter 62 | text : String) -- Text to encode 63 | return String 64 | is 65 | use Ada.Strings.Unbounded, Bar_Codes; 66 | svg_code : Unbounded_String; 67 | -- 68 | type SVG_BC is new Bar_Code with null record; 69 | -- 70 | overriding procedure Filled_Rectangle (bc : SVG_BC; shape : Module_Box) is 71 | begin 72 | svg_code := svg_code & 73 | " " & ASCII.LF; 78 | end Filled_Rectangle; 79 | -- 80 | bc : SVG_BC; 81 | begin 82 | bc.Set_Bounding_Box (bounding); 83 | bc.Draw (kind, text); 84 | return 85 | "" & ASCII.LF & 86 | "" & ASCII.LF & 89 | "" & ASCII.LF & 90 | "" & ASCII.LF & 91 | "" & ASCII.LF & 92 | "" & ASCII.LF & 95 | -- White rectangle as background 96 | " " & ASCII.LF & 97 | To_String (svg_code) & 98 | "" & ASCII.LF & 99 | "" & ASCII.LF; 100 | end SVG_Bar_Code; 101 | 102 | ------------------------------------------------------------------------------------------- 103 | -- Generic drawing of bar codes on a black & white bitmap, for raster graphics outputs -- 104 | ------------------------------------------------------------------------------------------- 105 | 106 | generic 107 | scale_xx : Positive; 108 | scale_yy : Positive; 109 | width : Positive; 110 | height : Positive; 111 | package Bitmap_BC_Buffer is 112 | 113 | type Bit is range 0 .. 1; 114 | 115 | black : constant := 1; 116 | white : constant := 0; 117 | 118 | bitmap : 119 | array (0 .. scale_xx * width - 1, 120 | 0 .. scale_yy * height - 1) of Bit := 121 | (others => (others => white)); 122 | 123 | type Bitmap_BC is new Bar_Codes.Bar_Code with null record; 124 | overriding procedure Filled_Rectangle (bc : Bitmap_BC; shape : Bar_Codes.Module_Box); 125 | 126 | end Bitmap_BC_Buffer; 127 | 128 | package body Bitmap_BC_Buffer is 129 | 130 | overriding procedure Filled_Rectangle (bc : Bitmap_BC; shape : Bar_Codes.Module_Box) is 131 | pragma Unreferenced (bc); 132 | begin 133 | for x in scale_xx * shape.left .. scale_xx * (shape.left + shape.width) - 1 loop 134 | for y in scale_yy * shape.bottom .. scale_yy * (shape.bottom + shape.height) - 1 loop 135 | bitmap (x, y) := black; 136 | end loop; 137 | end loop; 138 | end Filled_Rectangle; 139 | 140 | end Bitmap_BC_Buffer; 141 | 142 | -------------------- 143 | -- PBM_Bar_Code -- 144 | -------------------- 145 | 146 | function PBM_Bar_Code 147 | (kind : Bar_Codes.Kind_Of_Code; 148 | scale_x, scale_y : Positive; -- Scaling factors for the bitmap rendering 149 | text : String) -- Text to encode 150 | return String 151 | is 152 | fit : constant Bar_Codes.Module_Box := Bar_Codes.Fitting (kind, text); 153 | 154 | package BC_BMP is 155 | new Bitmap_BC_Buffer 156 | (scale_xx => scale_x, 157 | scale_yy => scale_y, 158 | width => fit.width, 159 | height => fit.height); 160 | 161 | -- White space margin around the bar code 162 | margin : constant Positive := Integer'Min (scale_x, scale_y); 163 | total_width : constant Positive := BC_BMP.bitmap'Length (1) + 2 * margin; 164 | total_height : constant Positive := BC_BMP.bitmap'Length (2) + 2 * margin; 165 | 166 | pbm_code : String (1 .. (total_width * 2 + 1) * total_height); 167 | pbm_i : Positive := 1; 168 | 169 | bc : BC_BMP.Bitmap_BC; 170 | 171 | procedure White_Pixels (number : Positive) is 172 | begin 173 | for i in 1 .. number loop 174 | pbm_code (pbm_i .. pbm_i + 1) := "0 "; 175 | pbm_i := pbm_i + 2; 176 | end loop; 177 | end White_Pixels; 178 | 179 | procedure Horizontal_Margin is 180 | begin 181 | for row in 1 .. margin loop 182 | White_Pixels (total_width); 183 | pbm_code (pbm_i) := ASCII.LF; 184 | pbm_i := pbm_i + 1; 185 | end loop; 186 | end Horizontal_Margin; 187 | 188 | begin 189 | bc.Draw (kind, text); 190 | 191 | -- Top margin 192 | Horizontal_Margin; 193 | for y in reverse BC_BMP.bitmap'Range (2) loop 194 | -- Left margin 195 | White_Pixels (margin); 196 | for x in BC_BMP.bitmap'Range (1) loop 197 | pbm_code (pbm_i .. pbm_i + 1) := BC_BMP.bitmap (x, y)'Image; 198 | pbm_i := pbm_i + 2; 199 | end loop; 200 | -- Right margin 201 | White_Pixels (margin); 202 | pbm_code (pbm_i) := ASCII.LF; 203 | pbm_i := pbm_i + 1; 204 | end loop; 205 | -- Bottom margin 206 | Horizontal_Margin; 207 | 208 | return 209 | "P1" & ASCII.LF & 210 | "# Automatically generated by " & Bar_Codes.title & 211 | " version " & Bar_Codes.version & 212 | ", " & Bar_Codes.reference & ASCII.LF & 213 | "# Web: " & Bar_Codes.web & ASCII.LF & 214 | "# Requested bar code format: " & kind'Image & ASCII.LF & 215 | "# Text to be encoded: [" & Bar_Codes.Make_Printable (text) & "]" & ASCII.LF & 216 | total_width'Image & 217 | total_height'Image & ASCII.LF & 218 | pbm_code; 219 | end PBM_Bar_Code; 220 | 221 | -------------------- 222 | -- PNG_Bar_Code -- 223 | -------------------- 224 | 225 | procedure PNG_Bar_Code 226 | (kind : in Bar_Codes.Kind_Of_Code; 227 | scale_x, scale_y : in Positive; -- Scaling factors for the bitmap rendering 228 | text : in String; -- Text to encode 229 | output : in out Ada.Streams.Root_Stream_Type'Class) 230 | is 231 | fit : constant Bar_Codes.Module_Box := Bar_Codes.Fitting (kind, text); 232 | 233 | package BC_BMP is 234 | new Bitmap_BC_Buffer 235 | (scale_xx => scale_x, 236 | scale_yy => scale_y, 237 | width => fit.width, 238 | height => fit.height); 239 | 240 | -------------------------------------------------------------- 241 | -- Captive copy of Dumb_PNG, that can be found elsewhere, -- 242 | -- for instance in the GID (Generic Image Decoder) tests. -- 243 | -------------------------------------------------------------- 244 | package Dumb_PNG is 245 | 246 | type Byte_Array is array (Integer range <>) of Interfaces.Unsigned_8; 247 | type p_Byte_Array is access Byte_Array; 248 | procedure Dispose is new Ada.Unchecked_Deallocation (Byte_Array, p_Byte_Array); 249 | 250 | type Buffer_Mode is 251 | (packed, -- Raw, packed, 8-bit-per-channel RGB data. 252 | padded); -- Same but with a 0 byte at the beginning of each row (faster). 253 | 254 | procedure Write 255 | (data : in Byte_Array; 256 | data_mode : in Buffer_Mode; 257 | width : in Integer; -- Image width 258 | height : in Integer; -- Image height 259 | s : in out Ada.Streams.Root_Stream_Type'Class); 260 | 261 | end Dumb_PNG; 262 | 263 | package body Dumb_PNG is 264 | 265 | use Ada.Streams, Interfaces; 266 | 267 | procedure Deflate 268 | (data : in Byte_Array; 269 | defl_output : out Byte_Array; 270 | last : out Integer); 271 | 272 | procedure Write_Chunk 273 | (chunk_type, chunk_data : in Byte_Array; 274 | s : in out Root_Stream_Type'Class); 275 | 276 | -- 277 | 278 | function To_Bytes_Big_Endian (x : Unsigned_32) return Byte_Array; 279 | 280 | procedure Write 281 | (data : in Byte_Array; 282 | data_mode : in Buffer_Mode; 283 | width : in Integer; -- Image width 284 | height : in Integer; -- Image height 285 | s : in out Ada.Streams.Root_Stream_Type'Class) 286 | is 287 | ihdr : Byte_Array (0 .. 12); 288 | 289 | function To_Bytes (s : String) return Byte_Array is 290 | result : Byte_Array (s'Range); 291 | begin 292 | for i in s'Range loop 293 | result (i) := Character'Pos (s (i)); 294 | end loop; 295 | return result; 296 | end To_Bytes; 297 | 298 | procedure Process_IDAT (idat : Byte_Array) is 299 | idat_deflated : p_Byte_Array; 300 | deflated_size : Integer; 301 | deflated_last : Integer; 302 | begin 303 | -- The "compressed" size is larger than the uncompressed one :-) 304 | -- 305 | deflated_size := 6 + idat'Length + 5 * (1 + idat'Length / 16#FFFF#); 306 | 307 | idat_deflated := new Byte_Array (0 .. deflated_size); 308 | 309 | Deflate (idat, idat_deflated.all, deflated_last); 310 | Write_Chunk (To_Bytes ("IDAT"), idat_deflated (0 .. deflated_last), s); 311 | 312 | Dispose (idat_deflated); 313 | end Process_IDAT; 314 | 315 | idat_composed : p_Byte_Array; 316 | row_size : Integer; 317 | index_data : Integer; 318 | index : Integer; 319 | 320 | begin 321 | -- PNG header 322 | Byte_Array'Write 323 | (s'Access, 324 | 16#89# & To_Bytes ("PNG") & (13, 10, 16#1A#, 10)); 325 | 326 | -- IHDR chunk 327 | ihdr (0 .. 3) := To_Bytes_Big_Endian (Unsigned_32 (width)); 328 | ihdr (4 .. 7) := To_Bytes_Big_Endian (Unsigned_32 (height)); 329 | ihdr (8) := 8; -- Bit depth: 8 bits per sample 330 | ihdr (9) := 2; -- Color type: True color RGB 331 | ihdr (10) := 0; -- Compression method: DEFLATE 332 | ihdr (11) := 0; -- Filter method: Adaptive 333 | ihdr (12) := 0; -- Interlace method: None 334 | Write_Chunk (To_Bytes ("IHDR"), ihdr, s); 335 | 336 | case data_mode is 337 | 338 | when packed => 339 | -- IDAT chunk (pixel values and row filters) 340 | -- Note: One additional byte at the beginning of each 341 | -- row specifies the filtering method. 342 | row_size := width * 3 + 1; 343 | idat_composed := new Byte_Array (0 .. row_size * height - 1); 344 | -- 345 | -- The extra buffer (idat_composed.all) differs from the data 346 | -- only for the additional 0 before each row. 347 | -- 348 | for y in 0 .. height - 1 loop 349 | idat_composed (y * row_size) := 0; -- Filter type: None 350 | for x in 0 .. width - 1 loop 351 | index := y * row_size + 1 + x * 3; 352 | index_data := data'First + y * width * 3 + x * 3; 353 | idat_composed (index + 0) := data (index_data + 0); -- Red 354 | idat_composed (index + 1) := data (index_data + 1); -- Green 355 | idat_composed (index + 2) := data (index_data + 2); -- Blue 356 | end loop; 357 | end loop; 358 | -- 359 | Process_IDAT (idat_composed.all); 360 | Dispose (idat_composed); 361 | 362 | when padded => 363 | -- Under this form, the data is already fit for being sent directly. 364 | Process_IDAT (data); 365 | 366 | end case; 367 | 368 | Write_Chunk (To_Bytes ("IEND"), (1 .. 0 => 0), s); 369 | end Write; 370 | 371 | procedure Deflate 372 | (data : in Byte_Array; 373 | defl_output : out Byte_Array; 374 | last : out Integer) 375 | is 376 | procedure Write (b : Unsigned_8) is 377 | begin 378 | last := last + 1; 379 | defl_output (last) := b; 380 | end Write; 381 | 382 | offset : Integer := 0; 383 | start : Integer; 384 | cur_block_size : Integer; 385 | adler_1 : Unsigned_32 := 1; 386 | adler_2 : Unsigned_32 := 0; 387 | modulus : constant := 65521; 388 | begin 389 | last := defl_output'First - 1; 390 | -- zlib header 391 | Write (16#08#); 392 | Write (16#1D#); 393 | 394 | -- Deflate data 395 | loop 396 | cur_block_size := Integer'Min (data'Length - offset, 16#FFFF#); 397 | -- Block type: Store; final flag if last block. 398 | Write (if offset + cur_block_size = data'Length then 1 else 0); 399 | Write (Unsigned_8 (cur_block_size rem 256)); 400 | Write (Unsigned_8 ((cur_block_size / 256) rem 256)); 401 | Write (not Unsigned_8 (cur_block_size rem 256)); 402 | Write (not Unsigned_8 ((cur_block_size / 256) rem 256)); 403 | start := data'First + offset; 404 | for i in start .. start + cur_block_size - 1 loop 405 | Write (data (i)); 406 | end loop; 407 | offset := offset + cur_block_size; 408 | exit when offset >= data'Length; 409 | end loop; 410 | 411 | for b of data loop 412 | adler_1 := (adler_1 + Unsigned_32 (b)) rem modulus; 413 | adler_2 := (adler_2 + adler_1) rem modulus; 414 | end loop; 415 | Write (Unsigned_8 (adler_2 / 256)); 416 | Write (Unsigned_8 (adler_2 rem 256)); 417 | Write (Unsigned_8 (adler_1 / 256)); 418 | Write (Unsigned_8 (adler_1 rem 256)); 419 | end Deflate; 420 | 421 | package CRC32 is 422 | procedure Init (crc : out Unsigned_32); 423 | function Final (crc : Unsigned_32) return Unsigned_32; 424 | procedure Update (crc : in out Unsigned_32; in_buf : Byte_Array); 425 | end CRC32; 426 | 427 | procedure Write_U32 428 | (x : in Unsigned_32; 429 | s : in out Root_Stream_Type'Class); 430 | 431 | procedure Write_Chunk 432 | (chunk_type, chunk_data : in Byte_Array; 433 | s : in out Root_Stream_Type'Class) 434 | is 435 | c : Unsigned_32; 436 | begin 437 | CRC32.Init (c); 438 | CRC32.Update (c, chunk_type); 439 | CRC32.Update (c, chunk_data); 440 | Write_U32 (chunk_data'Length, s); 441 | Byte_Array'Write (s'Access, chunk_type); 442 | Byte_Array'Write (s'Access, chunk_data); 443 | Write_U32 (CRC32.Final (c), s); 444 | end Write_Chunk; 445 | 446 | procedure Write_U32 447 | (x : in Unsigned_32; 448 | s : in out Root_Stream_Type'Class) 449 | is 450 | begin 451 | Byte_Array'Write (s'Access, To_Bytes_Big_Endian (x)); 452 | end Write_U32; 453 | 454 | function To_Bytes_Big_Endian (x : Unsigned_32) return Byte_Array is 455 | result : Byte_Array (1 .. 4); 456 | begin 457 | result (1) := Unsigned_8 (Shift_Right (x, 24)); 458 | result (2) := Unsigned_8 (Shift_Right (x, 16) and 255); 459 | result (3) := Unsigned_8 (Shift_Right (x, 8) and 255); 460 | result (4) := Unsigned_8 (x and 255); 461 | return result; 462 | end To_Bytes_Big_Endian; 463 | 464 | package body CRC32 is 465 | 466 | CRC32_Table : array (Unsigned_32'(0) .. 255) of Unsigned_32; 467 | 468 | procedure Prepare_Table is 469 | -- CRC-32 algorithm, ISO-3309 470 | Seed : constant := 16#EDB88320#; 471 | l : Unsigned_32; 472 | begin 473 | for i in CRC32_Table'Range loop 474 | l := i; 475 | for bit in 0 .. 7 loop 476 | if (l and 1) = 0 then 477 | l := Shift_Right (l, 1); 478 | else 479 | l := Shift_Right (l, 1) xor Seed; 480 | end if; 481 | end loop; 482 | CRC32_Table (i) := l; 483 | end loop; 484 | end Prepare_Table; 485 | 486 | procedure Update (crc : in out Unsigned_32; in_buf : Byte_Array) is 487 | local_CRC : Unsigned_32; 488 | begin 489 | local_CRC := crc; 490 | for i in in_buf'Range loop 491 | local_CRC := 492 | CRC32_Table (16#FF# and (local_CRC xor Unsigned_32 (in_buf (i)))) 493 | xor 494 | Shift_Right (local_CRC, 8); 495 | end loop; 496 | crc := local_CRC; 497 | end Update; 498 | 499 | table_empty : Boolean := True; 500 | 501 | procedure Init (crc : out Unsigned_32) is 502 | begin 503 | if table_empty then 504 | Prepare_Table; 505 | table_empty := False; 506 | end if; 507 | crc := 16#FFFF_FFFF#; 508 | end Init; 509 | 510 | function Final (crc : Unsigned_32) return Unsigned_32 is 511 | begin 512 | return not crc; 513 | end Final; 514 | 515 | end CRC32; 516 | 517 | end Dumb_PNG; 518 | 519 | -- White space margin around the bar code 520 | margin : constant Positive := Integer'Min (scale_x, scale_y); 521 | total_width : constant Positive := BC_BMP.bitmap'Length (1) + 2 * margin; 522 | total_height : constant Positive := BC_BMP.bitmap'Length (2) + 2 * margin; 523 | 524 | rgb_code : Dumb_PNG.Byte_Array (1 .. total_width * total_height * 3); 525 | 526 | rgb_i : Positive := 1; 527 | -- 528 | bc : BC_BMP.Bitmap_BC; 529 | use Interfaces; 530 | value : Unsigned_8; 531 | 532 | procedure White_Pixels (number : Positive) is 533 | channels : constant := 3; 534 | begin 535 | for i in 1 .. number * channels loop 536 | rgb_code (rgb_i) := 255; 537 | rgb_i := rgb_i + 1; 538 | end loop; 539 | end White_Pixels; 540 | 541 | procedure Horizontal_Margin is 542 | begin 543 | White_Pixels (margin * total_width); 544 | end Horizontal_Margin; 545 | 546 | begin 547 | bc.Draw (kind, text); 548 | -- Top margin 549 | Horizontal_Margin; 550 | for y in reverse BC_BMP.bitmap'Range (2) loop 551 | -- Left margin 552 | White_Pixels (margin); 553 | for x in BC_BMP.bitmap'Range (1) loop 554 | value := 255 - 255 * Unsigned_8 (BC_BMP.bitmap (x, y)); 555 | for channel in 1 .. 3 loop 556 | rgb_code (rgb_i) := value; 557 | rgb_i := rgb_i + 1; 558 | end loop; 559 | end loop; 560 | -- Right margin 561 | White_Pixels (margin); 562 | end loop; 563 | -- Bottom margin 564 | Horizontal_Margin; 565 | 566 | Dumb_PNG.Write (rgb_code, Dumb_PNG.packed, total_width, total_height, output); 567 | 568 | end PNG_Bar_Code; 569 | 570 | end Bar_Codes_Media; 571 | -------------------------------------------------------------------------------- /bar_codes-encode_qr.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- QR Code generator library (Ada) 3 | -- 4 | -- Copyright (c) Gautier de Montmollin (Ada translation & further development) 5 | -- http://ada-bar-codes.sf.net 6 | -- https://github.com/zertovitch/ada-bar-codes 7 | -- 8 | -- Copyright (c) Project Nayuki 9 | -- https://www.nayuki.io/page/qr-code-generator-library 10 | -- 11 | -- (MIT License) 12 | -- Permission is hereby granted, free of charge, to any person obtaining a copy of 13 | -- this software and associated documentation files (the "Software"), to deal in 14 | -- the Software without restriction, including without limitation the rights to 15 | -- use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of 16 | -- the Software, and to permit persons to whom the Software is furnished to do so, 17 | -- subject to the following conditions: 18 | -- - The above copyright notice and this permission notice shall be included in 19 | -- all copies or substantial portions of the Software. 20 | -- - The Software is provided "as is", without warranty of any kind, express or 21 | -- implied, including but not limited to the warranties of merchantability, 22 | -- fitness for a particular purpose and noninfringement. In no event shall the 23 | -- authors or copyright holders be liable for any claim, damages or other 24 | -- liability, whether in an action of contract, tort or otherwise, arising from, 25 | -- out of or in connection with the Software or the use or other dealings in the 26 | -- Software. 27 | 28 | with Ada.Text_IO; 29 | with Interfaces; 30 | 31 | separate (Bar_Codes) 32 | 33 | package body Encode_QR is 34 | 35 | use Ada.Text_IO, Interfaces; 36 | 37 | subtype QR_Version is Integer range 1 .. 40; 38 | 39 | -- Returns the number of data bits that can be stored in a QR Code of the given version number, after 40 | -- all function modules are excluded. This includes remainder bits, so it might not be a multiple of 8. 41 | -- The result is in the range [208, 29648]. 42 | -- 43 | function Get_Num_Raw_Data_Modules (ver : QR_Version) return Positive is 44 | result : Positive := (16 * ver + 128) * ver + 64; 45 | numAlign : constant Natural := ver / 7 + 2; 46 | num_alignment_pattern_modules : constant Natural := (25 * numAlign - 10) * numAlign - 55; 47 | num_version_information_modules : constant Natural := 18 * 2; 48 | begin 49 | if ver >= 2 then 50 | result := result - num_alignment_pattern_modules; 51 | if ver >= 7 then 52 | result := result - num_version_information_modules; 53 | end if; 54 | end if; 55 | if verbosity_level > 2 then 56 | Put_Line 57 | ("Get_Num_Raw_Data_Modules: result" & result'Image & " version" & ver'Image); 58 | end if; 59 | return result; 60 | end Get_Num_Raw_Data_Modules; 61 | 62 | type Error_Correction_Level is (LOW, MEDIUM, QUARTILE, HIGH); 63 | 64 | type QR_Param is array (Error_Correction_Level, QR_Version) of Positive; 65 | 66 | ECC_CODEWORDS_PER_BLOCK : constant QR_Param := ( 67 | -- 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40 Error correction level 68 | (7, 10, 15, 20, 26, 18, 20, 24, 30, 18, 20, 24, 26, 30, 22, 24, 28, 30, 28, 28, 28, 28, 30, 30, 26, 28, 30, 30, 30, 30, 30, 30, 30, 30, 30, 30, 30, 30, 30, 30), -- Low 69 | (10, 16, 26, 18, 24, 16, 18, 22, 22, 26, 30, 22, 22, 24, 24, 28, 28, 26, 26, 26, 26, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28), -- Medium 70 | (13, 22, 18, 26, 18, 24, 18, 22, 20, 24, 28, 26, 24, 20, 30, 24, 28, 28, 26, 30, 28, 30, 30, 30, 30, 28, 30, 30, 30, 30, 30, 30, 30, 30, 30, 30, 30, 30, 30, 30), -- Quartile 71 | (17, 28, 22, 16, 22, 28, 26, 26, 24, 28, 24, 28, 22, 24, 24, 30, 28, 28, 26, 28, 30, 24, 30, 30, 30, 30, 30, 30, 30, 30, 30, 30, 30, 30, 30, 30, 30, 30, 30, 30)); -- High 72 | 73 | NUM_ERROR_CORRECTION_BLOCKS : constant QR_Param := ( 74 | -- 1, 2, 3, 4, 5, 6, 7, 8, 9,10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40 Error correction level 75 | (1, 1, 1, 1, 1, 2, 2, 2, 2, 4, 4, 4, 4, 4, 6, 6, 6, 6, 7, 8, 8, 9, 9, 10, 12, 12, 12, 13, 14, 15, 16, 17, 18, 19, 19, 20, 21, 22, 24, 25), -- Low 76 | (1, 1, 1, 2, 2, 4, 4, 4, 5, 5, 5, 8, 9, 9, 10, 10, 11, 13, 14, 16, 17, 17, 18, 20, 21, 23, 25, 26, 28, 29, 31, 33, 35, 37, 38, 40, 43, 45, 47, 49), -- Medium 77 | (1, 1, 2, 2, 4, 4, 6, 6, 8, 8, 8, 10, 12, 16, 12, 17, 16, 18, 21, 20, 23, 23, 25, 27, 29, 34, 34, 35, 38, 40, 43, 45, 48, 51, 53, 56, 59, 62, 65, 68), -- Quartile 78 | (1, 1, 2, 4, 4, 4, 5, 6, 8, 8, 11, 11, 16, 16, 18, 16, 19, 21, 25, 25, 25, 34, 30, 32, 35, 37, 40, 42, 45, 48, 51, 54, 57, 60, 63, 66, 70, 74, 77, 81)); -- High 79 | 80 | -- Returns the number of 8-bit data (i.e. not error correction) codewords contained in any 81 | -- QR Code of the given version number and error correction level, with remainder bits discarded. 82 | -- 83 | function Get_Num_Data_Codewords (ver : QR_Version; ecl : Error_Correction_Level) return Positive is 84 | (Get_Num_Raw_Data_Modules (ver) / 8 - 85 | ECC_CODEWORDS_PER_BLOCK (ecl, ver) * 86 | NUM_ERROR_CORRECTION_BLOCKS (ecl, ver)); 87 | 88 | type Segment_Mode is (NUMERIC, ALPHANUMERIC, BYTE, KANJI, ECI); 89 | 90 | type Char_Count_Bits is array (0 .. 2) of Natural; 91 | 92 | type Segment_Mode_Param is record 93 | mode_bits : Positive; 94 | cc_bits : Char_Count_Bits; 95 | end record; 96 | 97 | segment_params : constant array (Segment_Mode) of Segment_Mode_Param := 98 | (NUMERIC => (1, (10, 12, 14)), 99 | ALPHANUMERIC => (2, (9, 11, 13)), 100 | BYTE => (4, (8, 16, 16)), 101 | KANJI => (8, (8, 10, 12)), 102 | ECI => (7, (0, 0, 0))); 103 | 104 | function Get_Border_Size (test_version : QR_Version) return Positive is 105 | (test_version * 4 + 17); 106 | 107 | max_modules : constant Integer := Get_Border_Size (QR_Version'Last) ** 2; 108 | 109 | type Bit is range 0 .. 1; 110 | type Bit_Array is array (Positive range <>) of Bit; 111 | type Bit_Buffer is record 112 | length : Natural := 0; 113 | element : Bit_Array (1 .. max_modules); 114 | end record; 115 | 116 | subtype U8 is Unsigned_8; 117 | subtype U16 is Unsigned_16; 118 | subtype U32 is Unsigned_32; 119 | 120 | procedure Append (bb : in out Bit_Buffer; value : Bit) is 121 | begin 122 | bb.length := bb.length + 1; 123 | bb.element (bb.length) := value; 124 | end Append; 125 | 126 | procedure Append (bb : in out Bit_Buffer; values : Bit_Buffer) is 127 | begin 128 | for i in 1 .. values.length loop 129 | Append (bb, values.element (i)); 130 | end loop; 131 | end Append; 132 | 133 | procedure Append_Bits (bb : in out Bit_Buffer; value : U32; number_of_bits : Natural) is 134 | begin 135 | for pos in reverse 0 .. number_of_bits - 1 loop 136 | Append (bb, Bit (Shift_Right (value, pos) and 1)); 137 | end loop; 138 | end Append_Bits; 139 | 140 | type Byte_Array is array (Natural range <>) of U8; 141 | 142 | -- Packs this buffer's bits into bytes in big endian, 143 | -- padding with '0' bit values, and returns the new array. 144 | -- 145 | function Get_Bytes (bits : Bit_Buffer) return Byte_Array is 146 | result : Byte_Array (0 .. bits.length / 8 - 1) := (others => 0); 147 | idx : Integer; 148 | begin 149 | for i in 1 .. bits.length loop 150 | idx := (i - 1) / 8; 151 | result (idx) := result (idx) or 152 | Shift_Left (U8 (bits.element (i)), 7 - ((i - 1) mod 8)); 153 | end loop; 154 | if verbosity_level > 1 then 155 | for i in result'Range loop 156 | Put_Line ("Get_Bytes: " & i'Image & result (i)'Image); 157 | end loop; 158 | end if; 159 | return result; 160 | end Get_Bytes; 161 | 162 | type Segment is record 163 | mode : Segment_Mode; 164 | num_chars : Natural; 165 | bit_data : Bit_Buffer; 166 | end record; 167 | 168 | type Segment_List is array (Positive range <>) of Segment; 169 | 170 | function Num_Char_Count_Bits (seg_mode : Segment_Mode; ver : QR_Version) return Natural is 171 | (case ver is 172 | when 1 .. 9 => segment_params (seg_mode).cc_bits (0), 173 | when 10 .. 26 => segment_params (seg_mode).cc_bits (1), 174 | when 27 .. 40 => segment_params (seg_mode).cc_bits (2)); 175 | 176 | function Get_Total_Bits (segs : Segment_List; test_version : QR_Version) return Natural is 177 | result : Natural := 0; 178 | cc_bits : Positive; 179 | begin 180 | for i in segs'Range loop 181 | cc_bits := Num_Char_Count_Bits (segs (i).mode, test_version); 182 | if verbosity_level > 2 then 183 | Put_Line 184 | ("Get_Total_Bits: segment" & i'Image & 185 | " mode " & segs (i).mode'Image & 186 | " test_version" & test_version'Image & 187 | " cc_bits" & cc_bits'Image); 188 | end if; 189 | -- Fail if segment length value doesn't fit in the length field's bit-width 190 | if segs (i).num_chars >= 2 ** cc_bits then 191 | raise Cannot_Encode with "Segment data too long"; 192 | end if; 193 | result := result + 4 + cc_bits + segs (i).bit_data.length; 194 | end loop; 195 | return result; 196 | end Get_Total_Bits; 197 | 198 | function Compose_As_BYTE (text : String) return Segment is 199 | bit_soup : Bit_Buffer; 200 | begin 201 | if verbosity_level > 2 then 202 | Put_Line ("Compose_As_BYTE start"); 203 | end if; 204 | for i in text'Range loop 205 | Append_Bits (bit_soup, U32 (Character'Pos (text (i))), 8); 206 | end loop; 207 | if verbosity_level > 2 then 208 | Put_Line ("Compose_As_BYTE done"); 209 | end if; 210 | return (mode => BYTE, num_chars => text'Length, bit_data => bit_soup); 211 | end Compose_As_BYTE; 212 | 213 | function Compose_Segments (text : String) return Segment_List is 214 | begin 215 | return (1 => Compose_As_BYTE (text)); 216 | -- !! To do: split the text to make a smart mix of numeric, 217 | -- alphanumeric, etc. for having a compact encoding 218 | end Compose_Segments; 219 | 220 | function Get_min_version (ecl : Error_Correction_Level; text : String) return QR_Version is 221 | data_used_bits, data_capacity_bits : Positive; 222 | segs : constant Segment_List := Compose_Segments (text); 223 | begin 224 | for test_version in QR_Version loop 225 | data_capacity_bits := Get_Num_Data_Codewords (test_version, ecl) * 8; 226 | begin 227 | data_used_bits := Get_Total_Bits (segs, test_version); 228 | if verbosity_level > 2 then 229 | Put_Line 230 | ("Get_min_version: test QR version" & test_version'Image & 231 | " data_used_bits =" & data_used_bits'Image & 232 | " data_capacity_bits =" & data_capacity_bits'Image); 233 | end if; 234 | if data_used_bits <= data_capacity_bits then 235 | return test_version; 236 | end if; 237 | exception 238 | when Cannot_Encode => 239 | null; -- Skip this version: one segment's data would be too long 240 | end; 241 | end loop; 242 | raise Cannot_Encode with "Message to be encoded doesn't fit in any QR version"; 243 | end Get_min_version; 244 | 245 | --------------------------------------------------------------- 246 | -- Error correction codes (could be in a separate package) -- 247 | --------------------------------------------------------------- 248 | 249 | -- Returns the product of the two given field elements modulo GF(2^8/16#11D#). 250 | function Finite_Field_Multiply (x, y : U8) return U8 is 251 | z : U8 := 0; 252 | begin 253 | -- Russian peasant multiplication 254 | for i in reverse 0 .. 7 loop 255 | z := Shift_Left (z, 1) xor (Shift_Right (z, 7) * 16#1D#); 256 | z := z xor (Shift_Right (y, i) and 1) * x; 257 | end loop; 258 | return z; 259 | end Finite_Field_Multiply; 260 | 261 | -- Calculates the Reed-Solomon generator polynomial of the given degree, storing in result[0 : degree]. 262 | procedure Calc_Reed_Solomon_Generator (result : out Byte_Array) is 263 | degree : constant Positive := result'Last + 1; 264 | root : U8; 265 | begin 266 | -- Start with the monomial x^0 267 | result := (others => 0); 268 | result (degree - 1) := 1; 269 | -- Compute the product polynomial (x - r^0) * (x - r^1) * (x - r^2) * ... * (x - r^{degree-1}), 270 | -- drop the highest term, and store the rest of the coefficients in order of descending powers. 271 | -- Note that r = 2, which is a generator element of this field GF(2^8/16#11D#). 272 | root := 1; 273 | for i in 0 .. degree - 1 loop 274 | -- Multiply the current product by (x - r^i) 275 | for j in 0 .. degree - 1 loop 276 | result (j) := Finite_Field_Multiply (result (j), root); 277 | if j + 1 < degree then 278 | result (j) := result (j) xor result (j + 1); 279 | end if; 280 | end loop; 281 | root := Finite_Field_Multiply (root, 2); 282 | end loop; 283 | end Calc_Reed_Solomon_Generator; 284 | 285 | -- Calculates the remainder of the polynomial data when divided by the generator, where all 286 | -- polynomials are in big endian and the generator has an implicit leading 1 term, 287 | -- storing the result in result[0 : degree]. 288 | procedure Calc_Reed_Solomon_Remainder (data, generator : Byte_Array; result : out Byte_Array) is 289 | factor : U8; 290 | degree : constant Natural := generator'Length; 291 | -- Perform polynomial division 292 | begin 293 | if result'Length /= degree then 294 | raise Constraint_Error with "result must have the generator's length (= polynomial degree)"; 295 | end if; 296 | result := (others => 0); 297 | for i in data'Range loop 298 | factor := data (i) xor result (result'First); 299 | if verbosity_level > 2 then 300 | Put_Line ( 301 | "Calc_Reed_Solomon_Remainder: dumping data, factor: " & 302 | i'Image & data (i)'Image & factor'Image); 303 | end if; 304 | -- Shift. 305 | result (result'First .. result'First + degree - 2) := 306 | result (result'First + 1 .. result'First + degree - 1); 307 | result (result'First + degree - 1) := 0; 308 | for j in 0 .. degree - 1 loop 309 | result (result'First + j) := result (result'First + j) xor 310 | Finite_Field_Multiply (generator (generator'First + j), factor); 311 | end loop; 312 | end loop; 313 | end Calc_Reed_Solomon_Remainder; 314 | 315 | qr_kind_to_ecl : constant array (Code_QR) of Error_Correction_Level := 316 | (Code_QR_Low => LOW, 317 | Code_QR_Medium => MEDIUM, 318 | Code_QR_Quartile => QUARTILE, 319 | Code_QR_High => HIGH); 320 | 321 | ---------- 322 | -- Draw -- 323 | ---------- 324 | 325 | procedure Draw (bc : in out Bar_Code; text : String; qr_kind : Code_QR) 326 | is 327 | selected_ecl : constant Error_Correction_Level := qr_kind_to_ecl (qr_kind); 328 | min_version : constant QR_Version := Get_min_version (selected_ecl, text); 329 | border_size : constant Positive := Get_Border_Size (min_version); 330 | 331 | -- Coordinates in the QR square: 332 | subtype Module_Range is Integer range 0 .. border_size - 1; 333 | -- 334 | -- The grid y axis is top-down; coordinates are (y,x). 335 | subtype QR_Grid is Grid (Module_Range, Module_Range); 336 | -- 337 | module, is_function : QR_Grid := (others => (others => False)); 338 | -- 339 | -- Sets the color of a module and marks it as a function module. 340 | -- 341 | procedure Set_Function_Module (x, y : Module_Range; is_black : Boolean) is 342 | begin 343 | module (y, x) := is_black; 344 | is_function (y, x) := True; -- Cell is marked, be it black or white. 345 | end Set_Function_Module; 346 | -- 347 | -- Table 23: Mask pattern generation (8 different ways of XOR masking). 348 | type Mask_Pattern_Reference is range 0 .. 7; 349 | -- 350 | function Get_Bit (x : U16; bit_pos : Natural) return Boolean is 351 | ((Shift_Right (x, bit_pos) and 1) /= 0); 352 | -- 353 | -- 8.9 Format Information 354 | -- 355 | procedure Draw_Format_Bits (mask_ref : Mask_Pattern_Reference) is 356 | -- The Format Information is a 15 bit sequence containing 5 data bits, 357 | -- with 10 error correction bits calculated using the (15, 5) BCH code. 358 | data, bch : U16; 359 | begin 360 | -- Table 25 - Error correction level indicators 361 | case selected_ecl is 362 | when LOW => data := 1; 363 | when MEDIUM => data := 0; 364 | when QUARTILE => data := 3; 365 | when HIGH => data := 2; 366 | end case; 367 | data := Shift_Left (data, 3) + U16 (mask_ref); -- 5 bits data. 368 | -- Now we add 10 bits of an error-correcting code specific to the 369 | -- format bits only! Used: BCH (Bose-Chaudhuri-Hocquenghem) code. 370 | bch := data; 371 | for i in 1 .. 10 loop 372 | bch := Shift_Left (bch, 1) xor (Shift_Right (bch, 9) * 16#537#); 373 | end loop; 374 | data := Shift_Left (data, 10) + bch; 375 | -- Ensure that no combination of Error Correction Level and 376 | -- Mask Pattern Reference will result in an all-zero data string. 377 | data := data xor 2#101010000010010#; 378 | -- 379 | -- Figure 19 - Format Information positioning 380 | -- 381 | -- Draw first copy on top left corner 382 | for i in 0 .. 5 loop 383 | Set_Function_Module (8, i, Get_Bit (data, i)); 384 | end loop; 385 | Set_Function_Module (8, 7, Get_Bit (data, 6)); 386 | Set_Function_Module (8, 8, Get_Bit (data, 7)); 387 | Set_Function_Module (7, 8, Get_Bit (data, 8)); 388 | for i in 9 .. 14 loop 389 | Set_Function_Module (14 - i, 8, Get_Bit (data, i)); 390 | end loop; 391 | -- Draw second copy 392 | for i in 0 .. 7 loop 393 | Set_Function_Module (border_size - 1 - i, 8, Get_Bit (data, i)); 394 | end loop; 395 | for i in 8 .. 14 loop 396 | Set_Function_Module (8, border_size - 15 + i, Get_Bit (data, i)); 397 | end loop; 398 | -- The lonely Dark Module ("...shall always be dark and 399 | -- does not form part of the Format Information.") 400 | Set_Function_Module (8, border_size - 8, True); 401 | end Draw_Format_Bits; 402 | -- 403 | -- Draw patterns that do not belong to encoded data: the three 404 | -- big squares for finding the orientation and bounds, the small 405 | -- squares for alignment, etc. This is done before drawing the data. 406 | -- Function patterns are turned around when drawing data. 407 | -- 408 | procedure Draw_Function_Patterns is 409 | -- 7.3.2 - Draws a 7x7 finder pattern, plus the surrounding white 410 | -- border separator (7.3.3), with the center module at (x, y). 411 | -- 412 | procedure Draw_Finder_Pattern (x, y : Module_Range) is 413 | dist, xx, yy : Integer; 414 | begin 415 | for dx in -4 .. 4 loop 416 | for dy in -4 .. 4 loop 417 | dist := Integer'Max (abs dx, abs dy); -- Chebyshev / infinity norm 418 | xx := x + dx; 419 | yy := y + dy; 420 | if xx in Module_Range and then yy in Module_Range then 421 | Set_Function_Module (xx, yy, dist /= 2 and dist /= 4); 422 | end if; 423 | end loop; 424 | end loop; 425 | end Draw_Finder_Pattern; 426 | -- 427 | -- Annex E - Position of Alignment Patterns - Table E.1 428 | -- 429 | procedure Draw_Alignment_Patterns is 430 | -- Draws a 5x5 alignment pattern, with the center module at (x, y). 431 | procedure Draw_Alignment_Pattern (x, y : Module_Range) is 432 | dist : Integer; 433 | begin 434 | for dx in -2 .. 2 loop 435 | for dy in -2 .. 2 loop 436 | dist := Integer'Max (abs dx, abs dy); -- Chebyshev / infinity norm 437 | Set_Function_Module (x + dx, y + dy, dist /= 1); 438 | end loop; 439 | end loop; 440 | end Draw_Alignment_Pattern; 441 | -- 442 | num_align : Natural := 0; 443 | step : Integer := 26; 444 | pos : Integer := min_version * 4 + 10; 445 | align_pos : array (1 .. 7) of Integer; 446 | begin 447 | if min_version > 1 then 448 | num_align := min_version / 7 + 2; 449 | if min_version /= 32 then 450 | step := ((min_version * 4 + num_align * 2 + 1) / (2 * num_align - 2)) * 2; 451 | end if; 452 | align_pos (1) := 6; 453 | for i in reverse 2 .. num_align loop 454 | align_pos (i) := pos; 455 | pos := pos - step; 456 | end loop; 457 | end if; 458 | -- Draw the lattice 459 | for i in 1 .. num_align loop 460 | for j in 1 .. num_align loop 461 | if (i = 1 and j = 1) or 462 | (i = 1 and j = num_align) or 463 | (i = num_align and j = 1) 464 | then 465 | null; -- Skip the three finder corners 466 | else 467 | Draw_Alignment_Pattern (align_pos (i), align_pos (j)); 468 | end if; 469 | end loop; 470 | end loop; 471 | end Draw_Alignment_Patterns; 472 | -- 473 | -- 8.10 Version Information 474 | -- 475 | -- Draws two copies of the version bits (with its own error correction code), 476 | -- based on this object's version field (which only has an effect for 7 <= version <= 40). 477 | procedure Draw_Version is 478 | -- The Version Information is an 18 bit sequence containing 6 data bits, with 12 error 479 | -- correction bits calculated using the (18, 6) BCH code. 480 | data, bch : U16; 481 | a, b : Module_Range; 482 | data_bit : Boolean; 483 | begin 484 | if min_version < 7 then 485 | return; 486 | end if; 487 | -- Calculate error correction code and pack bits 488 | bch := U16 (min_version); 489 | for i in 1 .. 12 loop 490 | bch := Shift_Left (bch, 1) xor (Shift_Right (bch, 11) * 16#1F25#); 491 | end loop; 492 | data := Shift_Left (U16 (min_version), 12) + bch; 493 | -- Draw two copies 494 | for i in 0 .. 17 loop 495 | a := border_size - 11 + i mod 3; 496 | b := i / 3; 497 | data_bit := Get_Bit (data, i); 498 | Set_Function_Module (a, b, data_bit); 499 | Set_Function_Module (b, a, data_bit); 500 | end loop; 501 | end Draw_Version; 502 | -- 503 | begin 504 | -- 7.3.4 - Draw horizontal and vertical timing 505 | -- patterns (dotted lines). 506 | for i in Module_Range loop 507 | Set_Function_Module (6, i, i mod 2 = 0); 508 | Set_Function_Module (i, 6, i mod 2 = 0); 509 | end loop; 510 | -- 7.3.2 - Draw 3 finder patterns (all corners except bottom 511 | -- right; overwrites some timing modules) 512 | Draw_Finder_Pattern (3, 3); 513 | Draw_Finder_Pattern (border_size - 4, 3); 514 | Draw_Finder_Pattern (3, border_size - 4); 515 | -- 7.3.5 - Draw alignment patterns 516 | Draw_Alignment_Patterns; 517 | -- 518 | -- The mask ref. is fake; this is just for marking the modules 519 | -- as Function and avoid data being written there. 520 | Draw_Format_Bits (mask_ref => 0); 521 | -- 8.10 - Draw Version Information 522 | Draw_Version; 523 | end Draw_Function_Patterns; 524 | -- 525 | -- Appends error correction bytes to each block of the given data array, then interleaves bytes 526 | -- from the blocks and stores them in the result array. data (0 .. rawCodewords - totalEcc - 1) contains 527 | -- the input data. data (rawCodewords - totalEcc .. rawCodewords - 1) is used as a temporary work area. 528 | -- The final answer is stored in result. 529 | -- 530 | function Append_Error_Correction (in_data : Byte_Array) return Byte_Array is 531 | num_blocks : constant Integer := NUM_ERROR_CORRECTION_BLOCKS (selected_ecl, min_version); 532 | block_ECC_len : constant Integer := ECC_CODEWORDS_PER_BLOCK (selected_ecl, min_version); 533 | raw_code_words : constant Integer := Get_Num_Raw_Data_Modules (min_version) / 8; 534 | data_len : constant Integer := raw_code_words - block_ECC_len * num_blocks; 535 | num_short_blocks : constant Integer := num_blocks - raw_code_words mod num_blocks; 536 | short_block_data_len : constant Integer := raw_code_words / num_blocks - block_ECC_len; 537 | -- 538 | data, result : Byte_Array (0 .. raw_code_words - 1); 539 | generator : Byte_Array (0 .. block_ECC_len - 1); 540 | j, k, l, block_len : Integer; 541 | begin 542 | data (0 .. data_len - 1) := in_data; 543 | -- 544 | -- 8.5.2 Generating the error correction codeword 545 | -- 546 | -- Split data into blocks and append ECC after all data 547 | Calc_Reed_Solomon_Generator (generator); 548 | if verbosity_level > 2 then 549 | for i in generator'Range loop 550 | Put_Line ("Dumping ECC generator: " & i'Image & generator (i)'Image); 551 | end loop; 552 | end if; 553 | -- 554 | j := data_len; 555 | k := 0; 556 | for i in 0 .. num_blocks - 1 loop 557 | block_len := short_block_data_len; 558 | if i >= num_short_blocks then 559 | block_len := block_len + 1; 560 | end if; 561 | Calc_Reed_Solomon_Remainder ( 562 | data (k .. k + block_len - 1), 563 | generator, 564 | data (j .. j + generator'Length - 1) 565 | ); 566 | j := j + block_ECC_len; 567 | k := k + block_len; 568 | end loop; 569 | -- 570 | -- 8.6 Constructing the final message codeword sequence 571 | -- 572 | -- Interleave (not concatenate) the bytes from every block into a single sequence 573 | k := 0; 574 | for i in 0 .. num_blocks - 1 loop 575 | l := i; 576 | for j in 0 .. short_block_data_len - 1 loop 577 | result (l) := data (k); 578 | k := k + 1; 579 | l := l + num_blocks; 580 | end loop; 581 | if i >= num_short_blocks then 582 | k := k + 1; 583 | end if; 584 | end loop; 585 | k := (num_short_blocks + 1) * short_block_data_len; 586 | l := num_blocks * short_block_data_len; 587 | for i in num_short_blocks .. num_blocks - 1 loop 588 | result (l) := data (k); 589 | k := k + short_block_data_len + 1; 590 | l := l + 1; 591 | end loop; 592 | k := data_len; 593 | for i in 0 .. num_blocks - 1 loop 594 | l := data_len + i; 595 | for j in 0 .. block_ECC_len - 1 loop 596 | result (l) := data (k); 597 | k := k + 1; 598 | l := l + num_blocks; 599 | end loop; 600 | end loop; 601 | return result; 602 | end Append_Error_Correction; 603 | -- 604 | procedure Draw_Data is 605 | -- 606 | -- Draw codewords (data with ecc) in zigzag 607 | -- 608 | procedure Draw_Codewords (data_and_ecc_bytes : Byte_Array) is 609 | i : Integer := 0; -- Bit index into the data 610 | idx : Integer; -- Codeword (byte) index 611 | right : Integer := border_size - 1; -- Index of right column in each column pair 612 | x, y : Integer; 613 | upward : Boolean; 614 | begin 615 | loop 616 | if right = 6 then 617 | right := 5; 618 | end if; 619 | upward := (U32 (right + 1) and 2) = 0; 620 | for vert in Module_Range loop 621 | for j in 0 .. 1 loop 622 | x := right - j; -- Actual x coordinate 623 | -- Actual y coordinate: 624 | if upward then 625 | y := border_size - 1 - vert; 626 | else 627 | y := vert; 628 | end if; 629 | if not is_function (y, x) then 630 | idx := data_and_ecc_bytes'First + i / 8; 631 | if idx > data_and_ecc_bytes'Last then 632 | -- If there are any remainder bits (0 to 7), they are already 633 | -- set to 0/false/white when the grid of modules was initialized 634 | null; 635 | else 636 | module (y, x) := Get_Bit (U16 (data_and_ecc_bytes (idx)), 7 - (i mod 8)); 637 | end if; 638 | i := i + 1; 639 | end if; 640 | end loop; 641 | end loop; 642 | right := right - 2; 643 | exit when right < 1; 644 | end loop; 645 | end Draw_Codewords; 646 | -- 647 | -- Apply XOR mask 648 | -- 649 | -- XORs the data modules in this QR Code with the given mask pattern. Due to XOR's mathematical 650 | -- properties, calling applyMask(m) twice with the same value is equivalent to no change at all. 651 | -- This means it is possible to apply a mask, undo it, and try another mask. Note that a final 652 | -- well-formed QR Code symbol needs exactly one mask applied (not zero, not two, etc.). 653 | -- 654 | procedure Apply_Mask (mask_ref : Mask_Pattern_Reference) is 655 | invert : Boolean; 656 | begin 657 | for y in Module_Range loop 658 | for x in Module_Range loop 659 | if not is_function (y, x) then 660 | case mask_ref is 661 | when 0 => invert := (x + y) mod 2 = 0; 662 | when 1 => invert := y mod 2 = 0; 663 | when 2 => invert := x mod 3 = 0; 664 | when 3 => invert := (x + y) mod 3 = 0; 665 | when 4 => invert := (x / 3 + y / 2) mod 2 = 0; 666 | when 5 => invert := x * y mod 2 + x * y mod 3 = 0; 667 | when 6 => invert := (x * y mod 2 + x * y mod 3) mod 2 = 0; 668 | when 7 => invert := ((x + y) mod 2 + x * y mod 3) mod 2 = 0; 669 | end case; 670 | module (y, x) := module (y, x) xor invert; 671 | end if; 672 | end loop; 673 | end loop; 674 | end Apply_Mask; 675 | -- 676 | data_capacity_bits : constant Positive := Get_Num_Data_Codewords (min_version, selected_ecl) * 8; 677 | bb : Bit_Buffer; 678 | segs : constant Segment_List := Compose_Segments (text); 679 | pad_byte : U8; 680 | begin 681 | if verbosity_level > 2 then 682 | Put_Line ("Draw_Data: QR version:" & min_version'Image); 683 | Put_Line ("Draw_Data: data_capacity_bits:" & data_capacity_bits'Image); 684 | end if; 685 | -- Create the data bit string by concatenating all segments 686 | for si in segs'Range loop 687 | if verbosity_level > 2 then 688 | Put_Line ("Draw_Data: one segment, mode_bits:"); 689 | end if; 690 | Append_Bits (bb, U32 (segment_params (segs (si).mode).mode_bits), 4); 691 | if verbosity_level > 2 then 692 | Put_Line ("Draw_Data: one segment, num_chars:"); 693 | end if; 694 | Append_Bits (bb, U32 (segs (si).num_chars), Num_Char_Count_Bits (segs (si).mode, min_version)); 695 | if verbosity_level > 2 then 696 | Put_Line ("Draw_Data: one segment, contents length:" & segs (si).bit_data.length'Image); 697 | end if; 698 | -- Copy bits into concatenated buffer 699 | Append (bb, segs (si).bit_data); 700 | end loop; 701 | -- Add terminator and pad up to a byte if applicable 702 | if verbosity_level > 2 then 703 | Put_Line ("Draw_Data: terminator 1:"); 704 | end if; 705 | Append_Bits (bb, 0, Integer'Min (4, data_capacity_bits - bb.length)); 706 | if verbosity_level > 2 then 707 | Put_Line ("Draw_Data: terminator 2:"); 708 | end if; 709 | Append_Bits (bb, 0, (8 - bb.length mod 8) mod 8); 710 | if verbosity_level > 2 then 711 | Put_Line ("Draw_Data: padding:"); 712 | end if; 713 | -- Pad with alternate bytes until data capacity is reached 714 | pad_byte := 16#EC#; 715 | while bb.length < data_capacity_bits loop 716 | Append_Bits (bb, U32 (pad_byte), 8); 717 | pad_byte := pad_byte xor 16#EC# xor 16#11#; 718 | end loop; 719 | if verbosity_level > 2 then 720 | Put_Line ("Draw_Data: done padding"); 721 | end if; 722 | if bb.length mod 8 /= 0 then 723 | raise Constraint_Error with "Wrong padding"; 724 | end if; 725 | -- 726 | -- Now bb contains the exact bit sequence to be drawn, turn it into a byte buffer 727 | -- 728 | declare 729 | data_bytes : constant Byte_Array := Get_Bytes (bb); 730 | data_and_ecc_bytes : constant Byte_Array := Append_Error_Correction (data_bytes); 731 | -- !! To do: automatic mask selection (penalty etc.) 732 | mask_ref_chosen : constant Mask_Pattern_Reference := 0; 733 | begin 734 | if verbosity_level > 1 then 735 | for i in data_bytes'Range loop 736 | Put_Line ("Dumping data_bytes: " & i'Image & data_bytes (i)'Image); 737 | end loop; 738 | for i in data_and_ecc_bytes'Range loop 739 | Put_Line ("Dumping data_and_ecc_bytes: " & i'Image & data_and_ecc_bytes (i)'Image); 740 | end loop; 741 | end if; 742 | Draw_Codewords (data_and_ecc_bytes); 743 | Draw_Format_Bits (mask_ref_chosen); 744 | Apply_Mask (mask_ref_chosen); 745 | end; 746 | end Draw_Data; 747 | 748 | begin 749 | if verbosity_level > 0 then 750 | Put_Line ("[QR code] version" & min_version'Image); 751 | end if; 752 | Draw_Function_Patterns; 753 | Draw_Data; 754 | Output_to_Media (bc, border_size, border_size, module); 755 | end Draw; 756 | 757 | ------------- 758 | -- Fitting -- 759 | ------------- 760 | 761 | function Fitting (text : String; qr_kind : Code_QR) return Module_Box is 762 | border_size : constant Positive := 763 | Get_Border_Size (Get_min_version (qr_kind_to_ecl (qr_kind), text)); 764 | begin 765 | if verbosity_level > 0 then 766 | Put_Line ("[QR code] Fitting function"); 767 | end if; 768 | return (0, 0, border_size, border_size); 769 | end Fitting; 770 | 771 | end Encode_QR; 772 | --------------------------------------------------------------------------------