├── BRZO
├── src
    ├── qrc.mllib
    ├── qrc_fmt.mli
    ├── qrc_fmt.ml
    ├── qrc.mli
    └── qrc.ml
├── .gitignore
├── .merlin
├── test
    ├── vecs.ml
    ├── examples.ml
    ├── test_perf.ml
    ├── test_vecs.ml
    ├── qrtrip.ml
    └── test_props.ml
├── _tags
├── pkg
    ├── META
    └── pkg.ml
├── DEVEL.md
├── doc
    └── index.mld
├── LICENSE.md
├── CHANGES.md
├── README.md
├── opam
└── B0.ml


/BRZO:
--------------------------------------------------------------------------------
1 | (srcs-x pkg test tmp)
2 | 


--------------------------------------------------------------------------------
/src/qrc.mllib:
--------------------------------------------------------------------------------
1 | Qrc
2 | Qrc_fmt
3 | 


--------------------------------------------------------------------------------
/.gitignore:
--------------------------------------------------------------------------------
1 | _b0
2 | *.install
3 | _build
4 | tmp
5 | test/vecs.ml


--------------------------------------------------------------------------------
/.merlin:
--------------------------------------------------------------------------------
1 | PKG cmdliner b0.kit
2 | S src
3 | S test
4 | B _b0/**
5 | 


--------------------------------------------------------------------------------
/test/vecs.ml:
--------------------------------------------------------------------------------
1 | (* Generate them with self_vecs --gen > self_vecs.ml *)
2 | 
3 | let version = [||]
4 | 


--------------------------------------------------------------------------------
/_tags:
--------------------------------------------------------------------------------
1 | true : bin_annot, safe_string
2 | 
3 | <_b0> : -traverse
4 | <src> : include
5 | <test/qrtrip*> : package(unix cmdliner)


--------------------------------------------------------------------------------
/pkg/META:
--------------------------------------------------------------------------------
1 | description = "QR code encoder for OCaml"
2 | version = "%%VERSION_NUM%%"
3 | requires = ""
4 | archive(byte) = "qrc.cma"
5 | archive(native) = "qrc.cmxa"
6 | plugin(byte) = "qrc.cma"
7 | plugin(native) = "qrc.cmxs"
8 | exists_if = "qrc.cma qrc.cmxa"
9 | 


--------------------------------------------------------------------------------
/DEVEL.md:
--------------------------------------------------------------------------------
 1 | # Tests
 2 | 
 3 |     b0 test
 4 | 
 5 | 
 6 | If you are making changes to the library that must preserve QR matrix
 7 | outputs, make sure the following test passes:
 8 | 
 9 |     git checkout -b my-changes
10 |     b0 -- test_vecs --gen 
11 |     # … make changes …
12 |     b0 test
13 | 
14 | 
15 | 


--------------------------------------------------------------------------------
/pkg/pkg.ml:
--------------------------------------------------------------------------------
 1 | #!/usr/bin/env ocaml
 2 | #use "topfind"
 3 | #require "topkg"
 4 | open Topkg
 5 | 
 6 | let cmdliner = Conf.with_pkg "cmdliner"
 7 | 
 8 | let () =
 9 |   Pkg.describe "qrc" @@ fun c ->
10 |   let cmdliner = Conf.value c cmdliner in
11 |   Ok [ Pkg.mllib "src/qrc.mllib";
12 |        Pkg.bin ~cond:cmdliner "test/qrtrip";
13 |        Pkg.doc "doc/index.mld" ~dst:"odoc-pages/index.mld";  ]
14 | 


--------------------------------------------------------------------------------
/test/examples.ml:
--------------------------------------------------------------------------------
1 | (*---------------------------------------------------------------------------
2 |    Copyright (c) 2024 The qrc programmers. All rights reserved.
3 |    SPDX-License-Identifier: CC0-1.0
4 |   ---------------------------------------------------------------------------*)
5 | 
6 | let output_svg_qr data = match Qrc.encode data with
7 | | None -> prerr_endline "Data capacity exceeded!"
8 | | Some m -> print_endline (Qrc.Matrix.to_svg m)
9 | 


--------------------------------------------------------------------------------
/doc/index.mld:
--------------------------------------------------------------------------------
 1 | {0 Qrc {%html: <span class="version">%%VERSION%%</span>%}}
 2 | 
 3 | Qrc encodes your data into QR codes. It has built-in QR matrix
 4 | renderers for SVG, ANSI terminal and text.
 5 | 
 6 | See the {{!quick}quick start}.
 7 | 
 8 | {1:qrc Library [qrc]}
 9 | 
10 | {!modules:
11 | Qrc
12 | Qrc_fmt
13 | }
14 | 
15 | {1:quick Quick start}
16 | 
17 |   The following generates a QR code matrix for the given [data] bytes
18 |   and outputs it as an SVG image on [stdout].
19 | 
20 | {[
21 |   let output_svg_qr data = match Qrc.encode data with
22 |   | None -> prerr_endline "Data capacity exceeded!"
23 |   | Some m -> print_endline (Qrc.Matrix.to_svg m)
24 | ]}
25 | 


--------------------------------------------------------------------------------
/LICENSE.md:
--------------------------------------------------------------------------------
 1 | Copyright (c) 2020 The qrc programmers
 2 | 
 3 | Permission to use, copy, modify, and/or distribute this software for any
 4 | purpose with or without fee is hereby granted, provided that the above
 5 | copyright notice and this permission notice appear in all copies.
 6 | 
 7 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
 8 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
 9 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
10 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
11 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
12 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
13 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
14 | 


--------------------------------------------------------------------------------
/CHANGES.md:
--------------------------------------------------------------------------------
 1 | v0.2.0 2024-09-10 Zagreb 
 2 | ------------------------
 3 | 
 4 | - `Qrc.Matrix.to_svg`, change matrix rendering strategy. The result doesn't
 5 |   use xlink (no risk of identifier clashes when embedding), renders faster in
 6 |   browsers and is more compact (#1). Thanks to Alain Frisch for the patch.
 7 | 
 8 | - `qrtrip` tool. Fix `stdin` reading bug, newlines were being dropped
 9 |   and arbitrary binary input was impossible (#5).
10 | 
11 | - `qrtrip` tool. Incompatible change to fix the footgun UI. Before,
12 |   the optional positional argument was the message to QR encode, but
13 |   it feels natural to specify a file to QR encode. In which case you
14 |   would silently QR encode a file path… The optional argument is now a
15 |   file to read by default. Use option `-m/--message` to treat the
16 |   argument as the message and make the tool operate as it used to.
17 | 
18 | - Require OCaml 4.14.0.
19 | 
20 | v0.1.0 2020-10-22 Zagreb
21 | ------------------------
22 | 
23 | First release.
24 | 


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
 1 | qrc — QR code encoder for OCaml
 2 | ===============================
 3 | 
 4 | Qrc encodes your data into QR codes. It has built-in QR matrix
 5 | renderers for SVG, ANSI terminal and text.
 6 | 
 7 | Qrc is distributed under the ISC license. It has no dependencies.
 8 | 
 9 | Homepage: https://erratique.ch/software/qrc
10 | 
11 | # Installation
12 | 
13 | qrc can be installed with `opam`:
14 | 
15 |     opam install qrc
16 | 
17 | If you don't use `opam` consult the [`opam`](opam) file for build
18 | instructions.
19 | 
20 | # Documentation
21 | 
22 | The documentation can be consulted [online][doc] or via `odig doc
23 | qrc`.
24 | 
25 | Questions are welcome but better asked on the [OCaml forum][ocaml-forum] 
26 | than on the issue tracker.
27 | 
28 | [doc]: https://erratique.ch/software/qrc/doc
29 | [ocaml-forum]: https://discuss.ocaml.org/
30 | 
31 | # Sample programs
32 | 
33 | The [`qrtrip`](test/qrtrip.ml) tool generates QR codes from the
34 | command line.  It renders QR matrices to SVG, ANSI terminals and
35 | US-ASCII or UTF-8 text.
36 | 


--------------------------------------------------------------------------------
/opam:
--------------------------------------------------------------------------------
 1 | opam-version: "2.0"
 2 | name: "qrc"
 3 | synopsis: "QR code encoder for OCaml"
 4 | description: """\
 5 | Qrc encodes your data into QR codes. It has built-in QR matrix
 6 | renderers for SVG, ANSI terminal and text.
 7 | 
 8 | Qrc is distributed under the ISC license. It has no dependencies.
 9 | 
10 | Homepage: https://erratique.ch/software/qrc"""
11 | maintainer: "Daniel Bünzli <daniel.buenzl i@erratique.ch>"
12 | authors: "The qrc programmers"
13 | license: "ISC"
14 | tags: ["qr-code" "codec" "org:erratique"]
15 | homepage: "https://erratique.ch/software/qrc"
16 | doc: "https://erratique.ch/software/qrc/doc"
17 | bug-reports: "https://github.com/dbuenzli/qrc/issues"
18 | depends: [
19 |   "ocaml" {>= "4.14.0"}
20 |   "ocamlfind" {build}
21 |   "ocamlbuild" {build}
22 |   "topkg" {build & >= "1.1.0"}
23 |   "b0" {dev & with-test}
24 | ]
25 | depopts: ["cmdliner"]
26 | conflicts: [
27 |   "cmdliner" {< "1.3.0"}
28 | ]
29 | build: [
30 |   "ocaml"
31 |   "pkg/pkg.ml"
32 |   "build"
33 |   "--dev-pkg"
34 |   "%{dev}%"
35 |   "--with-cmdliner"
36 |   "%{cmdliner:installed}%"
37 | ]
38 | dev-repo: "git+https://erratique.ch/repos/qrc.git"
39 | 


--------------------------------------------------------------------------------
/test/test_perf.ml:
--------------------------------------------------------------------------------
 1 | (*---------------------------------------------------------------------------
 2 |    Copyright (c) 2020 The qrc programmers. All rights reserved.
 3 |    SPDX-License-Identifier: ISC
 4 |   ---------------------------------------------------------------------------*)
 5 | 
 6 | (* Generates one QR per version/ec_level with random data. *)
 7 | 
 8 | open B0_testing
 9 | 
10 | let random_data st =
11 |   let max = Qrc.Prop.mode_capacity (`V 40) `L `Byte in
12 |   let b = Bytes.create max in
13 |   for i = 0 to max - 1 do
14 |     Bytes.set b i (Char.chr (Random.State.int st 256))
15 |   done;
16 |   Bytes.unsafe_to_string b
17 | 
18 | let test_gen =
19 |   Test.test "generating QR codes for random data." @@ fun () ->
20 |   let data = random_data (Test.Rand.state ()) in
21 |   for v = 1 to 40 do
22 |     let gen version ec_level =
23 |       let mode = `Byte in
24 |       let max_len = Qrc.Prop.mode_capacity version ec_level mode in
25 |       let data = String.sub data 0 max_len in
26 |       let m = Option.get @@ Qrc.encode ~version ~ec_level ~mode data in
27 |       Sys.opaque_identity @@ ignore (m)
28 |     in
29 |     List.iter (gen (`V v)) [ `L; `M; `Q; `H ]
30 |   done
31 | 
32 | let main () = Test.main @@ fun () -> Test.autorun ()
33 | let () = if !Sys.interactive then () else exit (main ())
34 | 


--------------------------------------------------------------------------------
/src/qrc_fmt.mli:
--------------------------------------------------------------------------------
 1 | (*---------------------------------------------------------------------------
 2 |    Copyright (c) 2020 The qrc programmers. All rights reserved.
 3 |    SPDX-License-Identifier: ISC
 4 |   ---------------------------------------------------------------------------*)
 5 | 
 6 | (** QR matrix text formatters. *)
 7 | 
 8 | type t =
 9 |   ?invert:bool -> ?quiet_zone:bool -> Format.formatter -> Qrc.Matrix.t -> unit
10 | (** The type for QR matrix formatters. If [invert] is [true] (defaults
11 |     to [false]) black modules are white and vice-versa. If
12 |     [quiet_zone] is [true] (default) the surrounding frame of four zero
13 |     modules is added. *)
14 | 
15 | val pp_ascii : t
16 | (** [pp_ascii] uses two U+0020 ([' ']) for white modules and two U+0023
17 |     (['#']) for black ones. *)
18 | 
19 | val pp_ansi : t
20 | (** [pp_ansi] uses two ANSI white U+0020 ([' ']) for white modules and two
21 |     ANSI black U+0020 ([' ']) for black ones. *)
22 | 
23 | val pp_utf_8_full : t
24 | (** [pp_utf_8_full] uses two U+0020 ([' ']) for white modules and two
25 |     UTF-8 encoded U+2588 (FULL BLOCK) for black ones. *)
26 | 
27 | val pp_utf_8_half : t
28 | (** [pp_utf_8_half] fits two vertical modules per character. It uses
29 |     U+0020 ([' ']) and UTF-8 encoded U+2588 (FULL BLOCK), U+2584 (LOWER HALF
30 |     BLOCK) and U+2580 (UPPER HALF BLOCK). *)
31 | 


--------------------------------------------------------------------------------
/B0.ml:
--------------------------------------------------------------------------------
 1 | open B0_kit.V000
 2 | 
 3 | (* Library names *)
 4 | 
 5 | let b0_std = B0_ocaml.libname "b0.std"
 6 | let unix = B0_ocaml.libname "unix"
 7 | let cmdliner = B0_ocaml.libname "cmdliner"
 8 | let qrc = B0_ocaml.libname "qrc"
 9 | 
10 | (* Libraries *)
11 | 
12 | let qrc_lib = B0_ocaml.lib qrc ~srcs:[`Dir ~/"src"]
13 | 
14 | (* Tools *)
15 | 
16 | let qrtrip_tool =
17 |   let srcs = [ `File ~/"test/qrtrip.ml"] in
18 |   let requires = [qrc; unix; cmdliner] in
19 |   B0_ocaml.exe "qrtrip" ~srcs ~requires ~doc:"The qrtrip tool"
20 | 
21 | (* Tests *)
22 | 
23 | let test ?(requires = []) = B0_ocaml.test ~requires:(qrc :: b0_std :: requires)
24 | let test_perf = test ~/"test/test_perf.ml"
25 | let test_props = test ~/"test/test_props.ml"
26 | 
27 | let test_vecs =
28 |   let requires = [cmdliner] in
29 |   test ~/"test/test_vecs.ml" ~run:true ~requires ~srcs:[`File ~/"test/vecs.ml"]
30 | 
31 | let examples = test ~/"test/examples.ml"
32 | 
33 | (* Packs *)
34 | 
35 | let default =
36 |    let meta =
37 |    B0_meta.empty
38 |    |> ~~ B0_meta.authors ["The qrc programmers"]
39 |    |> ~~ B0_meta.maintainers ["Daniel Bünzli <daniel.buenzl i@erratique.ch>"]
40 |    |> ~~ B0_meta.homepage "https://erratique.ch/software/qrc"
41 |    |> ~~ B0_meta.online_doc "https://erratique.ch/software/qrc/doc"
42 |    |> ~~ B0_meta.licenses ["ISC"]
43 |    |> ~~ B0_meta.repo "git+https://erratique.ch/repos/qrc.git"
44 |    |> ~~ B0_meta.issues "https://github.com/dbuenzli/qrc/issues"
45 |    |> ~~ B0_meta.description_tags ["qr-code"; "codec"; "org:erratique"; ]
46 |    |> ~~ B0_opam.build
47 |      {|[["ocaml" "pkg/pkg.ml" "build" "--dev-pkg" "%{dev}%"
48 |                   "--with-cmdliner" "%{cmdliner:installed}%" ]]|}
49 |    |> ~~ B0_opam.depopts ["cmdliner", "";]
50 |    |> ~~ B0_opam.conflicts [ "cmdliner", {|< "1.3.0"|}; ]
51 |    |> ~~ B0_opam.depends
52 |      [ "ocaml", {|>= "4.14.0"|};
53 |        "ocamlfind", {|build|};
54 |        "ocamlbuild", {|build|};
55 |        "topkg", {|build & >= "1.1.0"|};
56 |        "b0", {|dev & with-test|};
57 |      ]
58 |    |> B0_meta.tag B0_opam.tag
59 |  in
60 |  B0_pack.make "default" ~doc:"The qrc package" ~meta ~locked:true @@
61 |  B0_unit.list ()
62 | 


--------------------------------------------------------------------------------
/test/test_vecs.ml:
--------------------------------------------------------------------------------
 1 | (*---------------------------------------------------------------------------
 2 |    Copyright (c) 2020 The qrc programmers. All rights reserved.
 3 |    SPDX-License-Identifier: ISC
 4 |   ---------------------------------------------------------------------------*)
 5 | 
 6 | open B0_testing
 7 | open B0_std
 8 | 
 9 | (* One matrix is generated per QR code version/ec level. The standard
10 |    has no test vectors and most QR code encoders out there seem to
11 |    disagree on their outputs, so this only tests the implementation
12 |    against new versions of itself. *)
13 | 
14 | let random_data seed =
15 |   Random.init seed;
16 |   let max = Qrc.Prop.mode_capacity (`V 40) `L `Byte in
17 |   let b = Bytes.create max in
18 |   for i = 0 to max - 1 do Bytes.set b i (Char.chr (Random.int 256)) done;
19 |   Bytes.unsafe_to_string b
20 | 
21 | let matrix_to_string m =
22 |   let bytes = Qrc.Matrix.bits m in
23 |   let b = Bytes.create (Bigarray.Array1.dim bytes) in
24 |   let get bits i = Char.chr (Bigarray.Array1.get bits i)in
25 |   for i = 0 to Bytes.length b - 1 do Bytes.set b i (get bytes i) done;
26 |   Bytes.unsafe_to_string b
27 | 
28 | let fold_all_qrs f acc data =
29 |   let acc = ref acc in
30 |   for v = 1 to 40 do
31 |     let gen version ec_level =
32 |       let mode = `Byte in
33 |       let max_len = Qrc.Prop.mode_capacity version ec_level mode in
34 |       let data = String.sub data 0 max_len in
35 |       let m = Option.get @@ Qrc.encode ~version ~ec_level ~mode data in
36 |       acc := f !acc ~version ~ec_level m
37 |     in
38 |     List.iter (gen (`V v)) [ `L; `M; `Q; `H ]
39 |   done;
40 |   !acc
41 | 
42 | let gen data file =
43 |   try
44 |     Fmt.epr "Writing vectors in %a@." Fmt.code file;
45 |     Out_channel.with_open_bin file @@ fun oc ->
46 |     let pr fmt = Printf.fprintf oc fmt in
47 |     let f acc ~version ~ec_level:e m =
48 |       let m = matrix_to_string m in
49 |       if e = `L then pr "[|\n"; pr "%S;\n" m; if e = `H then pr "|];\n"
50 |     in
51 |     pr "(* Self test vectors, generated by self_test.ml *)\n";
52 |     pr "let version = [|\n"; fold_all_qrs f () data; pr "|]\n";
53 |   with Sys_error e -> Test.failstop "%s" e
54 | 
55 | let data = Test.Arg.make ()
56 | let test_vectors =
57 |   Test.test' data "vectors" @@ fun data ->
58 |   let f () ~version:(`V version) ~ec_level:ec m =
59 |     let ec_idx = match ec with `L -> 0 | `M -> 1 | `Q -> 2 | `H -> 3 in
60 |     let test = Vecs.version.(version - 1).(ec_idx) in
61 |     if test = matrix_to_string m then () else
62 |     Test.fail "Mismatch error: version %d ec_level: %d" version ec_idx
63 |   in
64 |   fold_all_qrs f () data
65 | 
66 | let main () =
67 |   let action =
68 |     let open Cmdliner in
69 |     let gen = Arg.info ["gen"] ~doc:"Generate vectors in $(b,test/vecs.ml)" in
70 |     Arg.(value & vflag `Test [`Gen, gen])
71 |   in
72 |   Test.main' action @@ fun action ->
73 |   let data = random_data 1031 in
74 |   match action with
75 |   | `Gen -> gen data "test/vecs.ml"
76 |   | `Test ->
77 |       if Array.length Vecs.version = 40 then test_vectors data else
78 |       Test.log "@[<v>%a, generate them BEFORE making changes with:@,%a@]"
79 |         (Fmt.st [`Fg (`Yellow)]) "No test vectors"
80 |         Fmt.code "b0 -- test_vecs --gen"
81 | 
82 | 
83 | let () = if !Sys.interactive then () else exit (main ())
84 | 


--------------------------------------------------------------------------------
/src/qrc_fmt.ml:
--------------------------------------------------------------------------------
  1 | (*---------------------------------------------------------------------------
  2 |    Copyright (c) 2020 The qrc programmers. All rights reserved.
  3 |    SPDX-License-Identifier: ISC
  4 |   ---------------------------------------------------------------------------*)
  5 | 
  6 | type t =
  7 |   ?invert:bool -> ?quiet_zone:bool -> Format.formatter -> Qrc.Matrix.t -> unit
  8 | 
  9 | let pp_cut = Format.pp_print_cut
 10 | let pp_char c ppf () = Format.pp_print_char ppf c
 11 | let pp_str_char s ppf () = Format.pp_print_as ppf 1 s
 12 | let pp_twice pp ppf () = for i = 1 to 2 do pp ppf () done
 13 | let pp_quiet_cols ~pp_white ppf () = for i = 0 to 3 do pp_white ppf () done
 14 | let pp_quiet_line ~pp_white ppf m =
 15 |   Format.pp_open_hbox ppf (); pp_quiet_cols ~pp_white ppf ();
 16 |   for i = 0 to (Qrc.Matrix.w m) - 1 do pp_white ppf () done;
 17 |   pp_quiet_cols ~pp_white ppf (); Format.pp_close_box ppf ()
 18 | 
 19 | let pp_one_to_one
 20 |     ~pp_white ~pp_black ?(invert = false) ?(quiet_zone = true) ppf m
 21 |   =
 22 |   let pp_white = if invert then pp_black else pp_white
 23 |   and pp_black = if invert then pp_white else pp_black in
 24 |   let pp_quiet_cols = pp_quiet_cols ~pp_white in
 25 |   let pp_quiet_lines ppf m =
 26 |     for i = 0 to 3 do pp_quiet_line ~pp_white ppf m; pp_cut ppf (); done
 27 |   in
 28 |   let pp_start_line ppf () =
 29 |     Format.pp_open_hbox ppf (); if quiet_zone then pp_quiet_cols ppf ();
 30 |   in
 31 |   let pp_end_line ppf () =
 32 |     if quiet_zone then pp_quiet_cols ppf (); Format.pp_close_box ppf ();
 33 |     pp_cut ppf ();
 34 |   in
 35 |   Format.pp_open_vbox ppf 0; if quiet_zone then pp_quiet_lines ppf m;
 36 |   for y = 0 to (Qrc.Matrix.w m) - 1 do
 37 |     pp_start_line ppf ();
 38 |     for x = 0 to (Qrc.Matrix.w m) - 1 do
 39 |       if Qrc.Matrix.get m ~x ~y then pp_black ppf () else pp_white ppf ()
 40 |     done;
 41 |     pp_end_line ppf ();
 42 |   done;
 43 |   if quiet_zone then pp_quiet_lines ppf m; Format.pp_close_box ppf ()
 44 | 
 45 | let pp_two_v_to_one
 46 |   ~pp_00 ~pp_10 ~pp_01 ~pp_11 ?(invert = false) ?(quiet_zone = true) ppf m
 47 |   =
 48 |   let pp_00 = if invert then pp_11 else pp_00
 49 |   and pp_01 = if invert then pp_10 else pp_01
 50 |   and pp_10 = if invert then pp_01 else pp_10
 51 |   and pp_11 = if invert then pp_00 else pp_11 in
 52 |   let pp_quiet_cols = pp_quiet_cols ~pp_white:pp_00 in
 53 |   let pp_quiet_lines ppf m =
 54 |     for i = 0 to 1 do pp_quiet_line ~pp_white:pp_00 ppf m; pp_cut ppf (); done
 55 |   in
 56 |   let pp_start_line ppf () =
 57 |     Format.pp_open_hbox ppf (); if quiet_zone then pp_quiet_cols ppf ();
 58 |   in
 59 |   let pp_end_line ppf () =
 60 |     if quiet_zone then pp_quiet_cols ppf (); Format.pp_close_box ppf ();
 61 |     pp_cut ppf ();
 62 |   in
 63 |   Format.pp_open_vbox ppf 0; if quiet_zone then pp_quiet_lines ppf m;
 64 |   for y = 0 to (Qrc.Matrix.w m / 2) - 1 do
 65 |     pp_start_line ppf ();
 66 |     let y0 = y * 2 and y1 = y * 2 + 1 in
 67 |     for x = 0 to (Qrc.Matrix.w m) - 1 do
 68 |       let v0 = Qrc.Matrix.get m ~x ~y:y0 in
 69 |       let v1 = Qrc.Matrix.get m ~x ~y:y1 in
 70 |       if v0
 71 |       then (if v1 then pp_11 ppf () else pp_10 ppf ())
 72 |       else (if v1 then pp_01 ppf () else pp_00 ppf ())
 73 |     done;
 74 |     pp_end_line ppf ()
 75 |   done;
 76 |   if (Qrc.Matrix.w m) mod 2 = 1 then begin (* last line if odd w *)
 77 |     pp_start_line ppf ();
 78 |     let y = Qrc.Matrix.w m - 1 in
 79 |     for x = 0 to Qrc.Matrix.w m - 1 do
 80 |       if Qrc.Matrix.get m ~x ~y then pp_10 ppf () else pp_00 ppf ()
 81 |     done;
 82 |     pp_end_line ppf ()
 83 |   end;
 84 |   if quiet_zone then pp_quiet_lines ppf m; Format.pp_close_box ppf ()
 85 | 
 86 | let pp_ascii =
 87 |   let pp_white = pp_twice (pp_char ' ') and pp_black = pp_twice (pp_char '#') in
 88 |   pp_one_to_one ~pp_white ~pp_black
 89 | 
 90 | let pp_ansi =
 91 |   let pp_white = pp_str_char "\027[47m  \027[m" in
 92 |   let pp_black = pp_str_char "\027[40m  \027[m" in
 93 |   pp_one_to_one ~pp_white ~pp_black
 94 | 
 95 | let pp_utf_8_full =
 96 |   let pp_white = pp_twice (pp_char ' ') in
 97 |   let pp_black = pp_twice (pp_str_char "\u{2588}") in
 98 |   pp_one_to_one ~pp_white ~pp_black
 99 | 
100 | let pp_utf_8_half =
101 |   let pp_00 = pp_char ' ' in
102 |   let pp_10 = pp_str_char "\u{2580}" in
103 |   let pp_01 = pp_str_char "\u{2584}" in
104 |   let pp_11 = pp_str_char "\u{2588}" in
105 |   pp_two_v_to_one ~pp_00 ~pp_10 ~pp_01 ~pp_11
106 | 


--------------------------------------------------------------------------------
/test/qrtrip.ml:
--------------------------------------------------------------------------------
  1 | (*---------------------------------------------------------------------------
  2 |    Copyright (c) 2020 The qrc programmers. All rights reserved.
  3 |    SPDX-License-Identifier: ISC
  4 |   ---------------------------------------------------------------------------*)
  5 | 
  6 | let ( let* ) = Result.bind
  7 | let exec = Filename.basename Sys.executable_name
  8 | 
  9 | let tty_bold = "\027[01m"
 10 | let tty_red_bold = "\027[31;01m"
 11 | let tty_reset = "\027[m"
 12 | let pp_code ppf s = Format.fprintf ppf "@<0>%s%s@<0>%s" tty_bold s tty_reset
 13 | let log_err fmt =
 14 |   Format.eprintf ("@[%s: @<0>%s%s@<0>%s: " ^^ fmt ^^ "@]@.")
 15 |     exec tty_red_bold "Error" tty_reset
 16 | 
 17 | let log_if_error ~use = function Ok v -> v | Error e -> log_err "%s" e; use
 18 | 
 19 | let tty_cap_of_fd fd =
 20 |   let rec isatty fd = try Unix.isatty fd with
 21 |   | Unix.Unix_error (Unix.EINTR, _, _) -> isatty fd
 22 |   | Unix.Unix_error (e, _, _) -> false
 23 |   in
 24 |   if not (isatty fd) then `None else
 25 |   match Unix.getenv "TERM" with
 26 |   | exception Not_found -> `None | "" -> `None | "dumb" -> `None
 27 |   | v -> `Ansi
 28 | 
 29 | let read_file file =
 30 |   let read file ic = try Ok (In_channel.input_all ic) with
 31 |   | Sys_error e -> Error (Printf.sprintf "%s: %s" file e)
 32 |   in
 33 |   let binary_stdin () = In_channel.set_binary_mode In_channel.stdin true in
 34 |   try match file with
 35 |   | "-" -> binary_stdin (); read file In_channel.stdin
 36 |   | file -> In_channel.with_open_bin file (read file)
 37 |   with Sys_error e -> Error e
 38 | 
 39 | let write_file file s =
 40 |   let write file s oc = try Ok (Out_channel.output_string oc s) with
 41 |   | Sys_error e -> Error (Printf.sprintf "%s: %s" file e)
 42 |   in
 43 |   let binary_stdout () = Out_channel.(set_binary_mode stdout true) in
 44 |   try match file with
 45 |   | "-" -> binary_stdout (); write file s Out_channel.stdout
 46 |   | file -> Out_channel.with_open_bin file (write file s)
 47 |   with Sys_error e -> Error e
 48 | 
 49 | (* Encoding *)
 50 | 
 51 | let err_capacity = 1
 52 | 
 53 | let format_for_stdout () = match tty_cap_of_fd Unix.stdout with
 54 | | `None -> `Unicode_full | `Ansi -> `Ansi
 55 | 
 56 | let get_format outf = function
 57 | | Some format -> format
 58 | | None ->
 59 |     match outf with
 60 |     | "-" -> format_for_stdout ()
 61 |     | file when String.ends_with ~suffix:".svg" file -> `Svg
 62 |     | _ -> `Unicode_full
 63 | 
 64 | let output_matrix format outf ~invert ~quiet_zone m =
 65 |   let pp_svg ?invert ?quiet_zone ppf m =
 66 |     Format.pp_print_string ppf (Qrc.Matrix.to_svg ?invert ?quiet_zone m)
 67 |   in
 68 |   let pp = match get_format outf format with
 69 |   | `Ascii -> Qrc_fmt.pp_ascii
 70 |   | `Ansi -> Qrc_fmt.pp_ansi
 71 |   | `Svg -> pp_svg
 72 |   | `Unicode_half -> Qrc_fmt.pp_utf_8_half
 73 |   | `Unicode_full -> Qrc_fmt.pp_utf_8_full
 74 |   in
 75 |   let qr = Format.asprintf "@[%a@]" (pp ~invert ~quiet_zone) m in
 76 |   write_file outf qr
 77 | 
 78 | let encode
 79 |     ~format ~outf ~invert ~no_quiet_zone ~version ~ec_level ~mask ~is_msg
 80 |     ~file_or_msg
 81 |   =
 82 |   let* data = if is_msg then Ok file_or_msg else read_file file_or_msg in
 83 |   let quiet_zone = not no_quiet_zone in
 84 |   let version = Option.map (fun v -> `V v) version in
 85 |   match Qrc.encode ?mask ?version ?ec_level data with
 86 |   | Some m ->
 87 |       let* () = output_matrix format outf ~invert ~quiet_zone m in
 88 |       Ok Cmdliner.Cmd.Exit.ok
 89 |   | None ->
 90 |       let ec_level = match ec_level with None -> `M | Some l -> l in
 91 |       let version = match version with None -> `V 40 | Some v -> v in
 92 |       log_err
 93 |         "@[<v>QR capacity of %a bytes exhausted: data has %a bytes@,\
 94 |          Reduce error correction with %a or icrease the version with %a"
 95 |         pp_code (Int.to_string (Qrc.Prop.mode_capacity version ec_level `Byte))
 96 |         pp_code (Int.to_string (String.length data))
 97 |         pp_code "-c" pp_code "-v";
 98 |       Ok err_capacity
 99 | 
100 | (* Decoding *)
101 | 
102 | let decode () = Error "Sorry, unimplemented yet."
103 | 
104 | (* Tripping *)
105 | 
106 | let qrtrip
107 |     ~encode:enc ~format ~outf ~invert ~no_quiet_zone ~version ~ec_level ~mask
108 |     ~is_msg ~file_or_msg
109 |   =
110 |   log_if_error ~use:Cmdliner.Cmd.Exit.some_error @@
111 |   match enc with
112 |   | `Decode -> decode ()
113 |   | `Encode ->
114 |       encode ~format ~outf ~invert ~no_quiet_zone ~version ~ec_level ~mask
115 |         ~is_msg ~file_or_msg
116 | 
117 | (* Command line interface *)
118 | 
119 | open Cmdliner
120 | open Cmdliner.Term.Syntax
121 | 
122 | let int_range ~lo ~hi kind =
123 |   let err fmt = Format.ksprintf (fun e -> Error (`Msg e)) fmt in
124 |   let parse_range v = match int_of_string v with
125 |   | exception Failure _ -> err "%s: not an integer in %d-%d" v lo hi
126 |   | v when lo <= v && v <= hi -> Ok v
127 |   | v -> err "%d: invalid %s, must be in %d-%d" v kind lo hi
128 |   in
129 |   Arg.conv (parse_range, Format.pp_print_int)
130 | 
131 | let format =
132 |   let formats =
133 |     [ "ascii", `Ascii; "ansi", `Ansi; "svg", `Svg; "half", `Unicode_half;
134 |       "text", `Unicode_full ]
135 |   in
136 |   let doc =
137 |     "QR matrix output format. \
138 |      $(b,ascii) outputs US-ASCII characters, \
139 |      $(b,ansi) outputs ANSI terminal escape sequences, \
140 |      $(b,svg) outputs an SVG image,
141 |      $(b,text) outputs UTF-8 encoded Unicode full blocks, \
142 |      $(b,half) outputs UTF-8 encoded Unicode half blocks. If absent \
143 |      $(b,svg) is used if the file of $(b,-o) ends with $(b,.svg), $(b,ansi)
144 |      or $(b,full) is used on $(b,stdout) and $(b,full) otherwise.";
145 |   in
146 |   let env = Cmd.Env.info "QRTRIP_FORMAT" and docv = "FORMAT" in
147 |   let absent = "guess" in
148 |   let fconv = Arg.some (Arg.enum formats) in
149 |   Arg.(value & opt fconv None & info ~absent ~doc ~docv ["f"; "format"] ~env)
150 | 
151 | let invert =
152 |   let doc = "Invert QR matrix, black modules are white and vice-versa." in
153 |   Arg.(value & flag & info ["i"; "invert"] ~doc)
154 | 
155 | let no_quiet_zone =
156 |   let doc =
157 |     "Do not output the quiet zone. Not recommended, leave scanners in peace."
158 |   in
159 |   Arg.(value & flag & info ["no-quiet"] ~doc)
160 | 
161 | let outf =
162 |   let doc = "Output to $(docv). Standard output if unspecified." in
163 |   let docv = "FILE" in
164 |   Arg.(value & opt string "-" & info ["o"] ~doc ~docv)
165 | 
166 | let version =
167 |   let doc =
168 |     "Use QR code $(docv) (1-40) for encoding. This defines the matrix width \
169 |      (21-177). Not recommended, let the minimal needed version be selected."
170 |   in
171 |   let vconv = int_range ~lo:1 ~hi:40 "version" and absent = "minimal needed" in
172 |   Arg.(value & opt (some vconv) None &
173 |        info ["v"; "qr-version"] ~absent ~doc ~docv:"VERSION")
174 | 
175 | let mask =
176 |   let doc =
177 |     "Force QR mask to $(docv) (0-7) for encoding. This option should \
178 |      not be used, it is used for debugging."
179 |   in
180 |   let mconv = int_range ~lo:0 ~hi:7 "mask" and absent = "standard compliant" in
181 |   Arg.(value & opt (some mconv) None & info ["mask"] ~absent ~doc ~docv:"MASK")
182 | 
183 | let is_msg =
184 |   let doc = "Positional argument is the message to encode, not a file path." in
185 |   Arg.(value & flag & info ["m"; "message"] ~doc)
186 | 
187 | let file_or_msg =
188 |   let doc = "File or message (with option $(b,-m)) to encode. \
189 |              Standard input if unspecified." in
190 |   Arg.(value & pos 0 string "-" & info [] ~doc ~docv:"FILE")
191 | 
192 | let ec_level =
193 |   let levels = [ "L", `L; "M", `M; "Q", `Q; "H", `H ] in
194 |   let doc = Printf.sprintf
195 |       "Use error correction $(docv) for encoding. Must be %s. Respectively \
196 |        corresponds to 7%%, 15%%, 25%% and 30%% damage correction. A higher \
197 |        level may end up being used if that does not change the selected QR \
198 |        code version (its width)."
199 |       (Arg.doc_alts_enum levels)
200 |   in
201 |   let lconv = Arg.some ~none:"M" (Arg.enum levels) in
202 |   Arg.(value & opt lconv None & info ["c"; "ec-level"] ~doc ~docv:"LEVEL")
203 | 
204 | let encode =
205 |   let enc = Arg.info ["e"; "encode"] ~doc:"Encode a QR code (default)." in
206 |   let dec = Arg.info ["d"; "decode"] ~doc:"Decode a QR code (unimplemented)." in
207 |   Arg.(value & vflag `Encode  [`Encode, enc; `Decode, dec])
208 | 
209 | let err_capacity = 1
210 | 
211 | let qrtrip =
212 |   let doc = "QR encode data" in
213 |   let man = [
214 |     `S Manpage.s_description;
215 |     `P "$(iname) encodes data into QR codes. Examples:";
216 |     `Pre "$(iname) $(b,/path/to/file)            # QR code for file contents";
217 |     `Noblank;
218 |     `Pre "$(iname) $(b,-m https://example.org)   \
219 |           # QR code for https://example.org";
220 |     `Noblank;
221 |     `Pre "$(iname) $(b,-m https://example.org -o example.svg)"; `Noblank;
222 |     `Pre "$(iname) $(b,-f svg -m https://example.org > example.svg)"; `Noblank;
223 |     `Pre
224 |       "$(iname) $(b,-f svg -m https://example.org | show-url -t example.svg)";
225 |     `S Manpage.s_bugs;
226 |     `P "This program is distributed with the Qrc OCaml library.
227 |         See https://erratique.ch/software/qrc for contact information."; ]
228 |   in
229 |   let exits =
230 |     Cmd.Exit.info ~doc:"on QR code capacity exceeded." err_capacity ::
231 |     Cmd.Exit.defaults
232 |   in
233 |   Cmd.v (Cmd.info "qrtrip" ~version:"%%VERSION%%" ~doc ~man ~exits) @@
234 |   let+ encode and+ format and+ outf and+ invert and+ no_quiet_zone
235 |   and+ version and+ ec_level and+ mask and+ is_msg and+ file_or_msg in
236 |   qrtrip ~encode ~format ~outf ~invert ~no_quiet_zone
237 |     ~version ~ec_level ~mask ~is_msg ~file_or_msg
238 | 
239 | let main () = Cmd.eval' qrtrip
240 | let () = if !Sys.interactive then () else exit (main ())
241 | 


--------------------------------------------------------------------------------
/src/qrc.mli:
--------------------------------------------------------------------------------
  1 | (*---------------------------------------------------------------------------
  2 |    Copyright (c) 2020 The qrc programmers. All rights reserved.
  3 |    SPDX-License-Identifier: ISC
  4 |   ---------------------------------------------------------------------------*)
  5 | 
  6 | (** QR code encoder.
  7 | 
  8 |     Consult the {{!notes_limits}limitations} and the {{!page-index.quick}
  9 |     quick start}.
 10 | 
 11 |     {b References.}
 12 | 
 13 |     ISO/IEC 18004:2015. {e QR Code bar code symbology specification}. *)
 14 | 
 15 | (** {1:matrices Matrices} *)
 16 | 
 17 | (** QR 2D matrices. *)
 18 | module Matrix : sig
 19 | 
 20 |   type bits =
 21 |     (int, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t
 22 |   (** The type for sequence of bits. *)
 23 | 
 24 |   type t
 25 |   (** The type for 2D square matrices of {e modules} (binary pixels).
 26 | 
 27 |       For a matrix of width [w], the module at position ([0,0]) is the
 28 |       top-left corner, and ([w-1,w-1)] is the bottom-right corner. The quiet
 29 |       zone (surrounding frame of four zero modules) is not included. We
 30 |       store the bits in row-major order. *)
 31 | 
 32 |   val zero : w:int -> t
 33 |   (** [zero ~w] is a matrix of zeros of size [w]. *)
 34 | 
 35 |   val of_bits : w:int -> bits -> t
 36 |   (** [of_bits ~w bits] is a matrix from the sequence of bits [bits]
 37 |       interpreted in row-major order. Exceeding final bits are ignored.
 38 | 
 39 |       @raise Invalid_argument if less than [w]{^2} bits are provided. *)
 40 | 
 41 |   val w : t -> int
 42 |   (** [w m] is the matrix width. *)
 43 | 
 44 |   val bits : t -> bits
 45 |   (** [bits m] are the matrix's bits (modules) in row-major order. If
 46 |       there are more bits than [(w m) * (w m)], exceeding final bits
 47 |       should be ignored. *)
 48 | 
 49 |   val copy : t -> t
 50 |   (** [copy m] is a copy of [m]. *)
 51 | 
 52 |   val get : t -> x:int -> y:int -> bool
 53 |   (** [get m ~x ~y] is the [(x,y)] module of [m]. *)
 54 | 
 55 |   val set : t -> x:int -> y:int -> unit
 56 |   (** [set m ~x ~y v] sets the [(x,y)] module of [m] to [true]. *)
 57 | 
 58 |   val clear : t -> x:int -> y:int -> unit
 59 |   (** [clear m ~x ~y] sets the [(x,y)] module of [m] to [false]. *)
 60 | 
 61 |   val fold : (int -> int -> bool -> 'a -> 'a) -> t -> 'a -> 'a
 62 |   (** [fold f m acc] folds [f] over all the modules [(x,y)] of [m] as [f x
 63 |       y (get m ~x ~y) acc'] in row-major order and starting with [acc]. *)
 64 | 
 65 |   val to_svg : ?w_mm:int -> ?invert:bool -> ?quiet_zone:bool -> t -> string
 66 |   (** [to_svg ~w_mm ~invert ~quiet_zone m] is an SVG image for
 67 |       [m] in a coordinate system using one (slightly larger) unit
 68 |       black square per set module. The image, including the quiet zone, has a
 69 |       width and height of [w_mm] millimeters (defaults to [50]).
 70 |       If [invert] is [true] (defaults to [false]) black modules are
 71 |       white and vice-versa. If [quiet_zone] is [true] (default) the
 72 |       surrounding frame of four zero modules is included. *)
 73 | end
 74 | 
 75 | (** {1:props Properties} *)
 76 | 
 77 | type version = [ `V of int ]
 78 | (** The type for QR code versions, from 1 to 40. *)
 79 | 
 80 | type ec_level =
 81 |   [ `L (** 7% *) | `M (** 15% *) | `Q (** 25% *) | `H (** 30% *) ]
 82 | (** The type for QR code error correction levels. Four levels respectively
 83 |     allowing 7%, 15%, 25% and 30% recovery of the QR code. *)
 84 | 
 85 | type mode = [ `Byte (** byte data *) ]
 86 | (** The type for (supported) data encoding modes. *)
 87 | 
 88 | (** Arithmetic over galois field GF(2{^8}). *)
 89 | module Gf_256 : sig
 90 | 
 91 |   type poly = int
 92 |   (** The type for degree 8 polynomials, using 0x1FF bits.  The
 93 |       [i]th zero-based bit index represents the coefficient (0 or 1) of
 94 |       the [i]th degree variable. *)
 95 | 
 96 |   type byte = int
 97 |   (** The type for bytes, the elements of GF(2{^8}). *)
 98 | 
 99 |   type t
100 |   (** A galois field instance for a given polynomial and generator. *)
101 | 
102 |   val create : r:poly -> g:byte -> t
103 |   (** [create ~r ~g] is a field modulo polynomial [r] (must be
104 |       irreducible) and generator [g]. [g] is the base for {!exp} and
105 |       {!log}. *)
106 | 
107 |   val add : byte -> byte -> byte
108 |   (** [add x y] is [y] added (xored) to [x]. *)
109 | 
110 |   val sub : byte -> byte -> byte
111 |   (** [sub x y] is [y] subtracted (xored) to [x]. *)
112 | 
113 |   val exp : t -> byte -> byte
114 |   (** [exp f x] is the base [g] exponential [g]{^[x]} in [f]. *)
115 | 
116 |   val log : t -> byte -> byte
117 |   (** [log f x] is [y] the base [g] logarithm of [x], i.e.
118 |       [g]{^[y]} = [x]. This is [255] if [x = 0]. *)
119 | 
120 |   val mul : t -> byte -> byte -> byte
121 |   (** [mul f x y] multiples [x] by [y] modulo [f]'s [r] polynomial. *)
122 | 
123 |   val inv : t -> byte -> byte
124 |   (** [inv f x] is [x]{^-1}, the multiplicative inverse of [x]. This is
125 |         [0] if [x] is [0]. *)
126 | end
127 | 
128 | (** QR code properties.
129 | 
130 |     Except for {!Prop.mode_capacity}, not for the casual user. *)
131 | module Prop : sig
132 | 
133 |   (** {1:version Version} *)
134 | 
135 |   val version_of_w : int -> (version, string) result
136 |   (** [version_of_w w] is the version associated to a matrix width of [w]
137 |       (without the quiet zone). *)
138 | 
139 |   val version_to_w : version -> int
140 |   (** [version_to_w v] is the matrix width (without the quiet zone)
141 |       for a QR code of version [v]. The result is between 21 to 177,
142 |       increasing by 4 with each version. *)
143 | 
144 |   (** {1:capacity Capacity} *)
145 | 
146 |   val total_bytes : version -> int
147 |   (** [total_bytes v] is the number of bytes available to encode data
148 |       in a QR code of version [v]. This includes the bytes used for
149 |       error correction. For all [ec_level] this is equal to {!data_bytes}[
150 |       v ec_level] + {!ec_bytes}[ v ec_level].
151 | 
152 |       This is ‘Total number of codewords’ in table 9 of
153 |       ISO/IEC 18004:2015. *)
154 | 
155 |   val data_bytes : version -> ec_level -> int
156 |   (** [data_bytes v ec_level] is the number of bytes that can be used
157 |       for data in a QR code of version [v] with error correction level
158 |       [ec_level]
159 | 
160 |       This is the ‘Number of data codewords’ in table 7 of
161 |       ISO/IEC 18004:2015.
162 | 
163 |       {b Warning.} Encoding the data into the actual
164 |       {!mode} uses a few additional bytes from these bytes. Use
165 |       {!mode_capacity} to determine the actual number of letters of
166 |       the given mode you can encode in a QR code. *)
167 | 
168 |   val ec_bytes : version -> ec_level -> int
169 |   (** [ec_bytes v ec_level] is the number of bytes used for error correction
170 |       in a QR code of version [v] with error correction level [ec_level].
171 | 
172 |       This is the ‘Number of error correction codewords’ in table 9 of
173 |       ISO/IEC 18004:2015. *)
174 | 
175 |   val ec_blocks : version -> ec_level -> int
176 |   (** [ec_blocks v ec_level] is the number of blocks by which the
177 |       data bytes to encode have to be divided and on which Reed-Solomon
178 |       error correction is performed.
179 | 
180 |       This is the ‘Number of error correction blocks’ in table 9 of
181 |       ISO/IEC 18004:2015. *)
182 | 
183 |   val mode_capacity : version -> ec_level -> mode -> int
184 |   (** [mode_capacity v ec_level mode] is the number of [mode]
185 |       {e letters} (that is bytes for [`Byte]) that can be encoded in a QR code
186 |       of version [v] and error correction [ec_level].
187 | 
188 |       This is the ‘Data capacity’ columns in table 7 of
189 |       ISO/IEC 18004:2015. *)
190 | 
191 |   (** {1:align_pats Alignment patterns}
192 | 
193 |       {b Note.} The result of the functions below for [`V 1] is undefined. *)
194 | 
195 |   val align_pat_count : version -> int
196 |   (** [align_pat_count v] is the (maximal) number of alignement
197 |       patterns along one dimension; square that and retract 3 to get the
198 |       total. *)
199 | 
200 |   val align_pat_last : version -> int
201 |   (** [align_pat_last v] is the [x] coordinate of the center of the last
202 |       (rightmost) alignement pattern in version [v]. *)
203 | 
204 |   val align_pat_delta : version -> int
205 |   (** [align_pat_delta v] is the distance between the centers of alignement
206 |       patterns from right to left, or bottom to top; except for the last
207 |       hop to column 6 or row 6 which absorbs the unevenness. *)
208 | 
209 |   val align_pat_center :
210 |     pat_count:int -> pat_last:int -> pat_delta:int -> int -> int
211 |   (** [align_pat_center ~pat_count ~pat_last ~pat_delta i] is the
212 |       center of the [i]th alignement pattern starting from [0] and
213 |       counting from left to right or top to bottom.
214 | 
215 |       This computes the values ‘Row/Columns coordinates of center module’
216 |       in table E.1 of ISO/IEC 18004:2015. *)
217 | 
218 |   (** {1:gf Galois field} *)
219 | 
220 |   val field : Gf_256.t Lazy.t
221 |   (** [field] is the Galois field used for error correction in QR codes,
222 |       the polynomial is 0b100011101 and the generator is [2]. *)
223 | 
224 |   val gen : Gf_256.t -> ec:int -> Gf_256.byte array
225 |   (** [gen f ec] is are the coefficients of the generator
226 |       polynomial (x - [g]{^0})·(x - [g]{^1})·…·(x - [g]{^[ec]})
227 |       with [g] the generator of [f] and [ec] the number of error
228 |       correcting bytes . *)
229 | end
230 | 
231 | (** {1:encoding Encoding} *)
232 | 
233 | val encode :
234 |   ?mask:int -> ?version:version -> ?mode:mode -> ?ec_level:ec_level ->
235 |   string -> Matrix.t option
236 | (** [encode ~version ~mode ~ec_level data] is a QR matrix encoding bytes
237 |     [data] with:
238 |     {ul
239 |     {- [ec_level], the error correction level, defaults to [`M].}
240 |     {- [version], the version of the QR code. If unspecified the minimal
241 |        needed version for the given [ec_level] is used.}
242 |     {- [mode] is the encoding mode. If unspecified it is guessed, but
243 |         guess what, only [`Byte] mode is supported.}
244 |     {- [mask] can be used to force the data mask. This should not
245 |        be used, the best mask to please your scanner is automatically
246 |        selected as mandated by the standard.}}
247 | 
248 |     [None] is returned if [data] is too large to be fit the specified
249 |     QR code parameters. Use {!Prop.mode_capacity} to find data
250 |     capacity for given QR code properties beforehand.
251 | 
252 |     {b Note.} Sometimes once the [version] and [ec_level] constraints
253 |     are satisfied for [data] we can fit the data in a higher
254 |     [ec_level] with the same [version] (i.e. same matrix width). In
255 |     that case that higher error correction level is used instead of
256 |     the given or default [ec_level]. *)
257 | 
258 | (** {1:notes_limits Notes and limitations}
259 | 
260 |     {2:encoding_limits Encoding}
261 | 
262 |     {ul
263 |     {- Only the (universal) byte mode data encoding is supported. This may
264 |        mean larger QR codes if you are trying to encode only decimal
265 |        digits, only decimal digits and uppercase US-ASCII letters
266 |        or only Kanji characters.}
267 |     {- For textual data, using UTF-8 with [`Bytes] should work reasonably
268 |        well. The module does not implement the ECI scheme to specify the
269 |        encoding. Signals from the interwebs seem to indicate it's better
270 |        to let scanners auto-discover the encoding as some do not
271 |        understand the ECI scheme.}
272 |     {- Structured append, i.e. data represented by up to 16 linked QR codes,
273 |        is not supported – who does ?}} *)
274 | 


--------------------------------------------------------------------------------
/test/test_props.ml:
--------------------------------------------------------------------------------
  1 | (*---------------------------------------------------------------------------
  2 |    Copyright (c) 2020 The qrc programmers. All rights reserved.
  3 |    SPDX-License-Identifier: ISC
  4 |   ---------------------------------------------------------------------------*)
  5 | 
  6 | open B0_testing
  7 | 
  8 | let div_round_up x y = (x + y - 1) / y
  9 | 
 10 | (* The tables from ISO/IEC 18004:2015(E) are highly interdependent, in Qrc
 11 |    we try to recover them from a minimal table. These tests make sure we
 12 |    got the data right. *)
 13 | 
 14 | (* Alignement patterns *)
 15 | 
 16 | let version_align_pat =  (* Table E.1 in Annex E *)
 17 |   [| [||];
 18 |      [|6;18|];
 19 |      [|6;22|];
 20 |      [|6;26|];
 21 |      [|6;30|];
 22 |      [|6;34|];
 23 |      [|6;22;38|];
 24 |      [|6;24;42|];
 25 |      [|6;26;46|];
 26 |      [|6;28;50|];
 27 |      (**)
 28 |      [|6;30;54|];
 29 |      [|6;32;58|];
 30 |      [|6;34;62|];
 31 |      [|6;26;46;66|];
 32 |      [|6;26;48;70|];
 33 |      [|6;26;50;74|];
 34 |      [|6;30;54;78|];
 35 |      [|6;30;56;82|];
 36 |      [|6;30;58;86|];
 37 |      [|6;34;62;90|];
 38 |      (**)
 39 |      [|6;28;50;72;94|];
 40 |      [|6;26;50;74;98|];
 41 |      [|6;30;54;78;102|];
 42 |      [|6;28;54;80;106|];
 43 |      [|6;32;58;84;110|];
 44 |      [|6;30;58;86;114|];
 45 |      [|6;34;62;90;118|];
 46 |      [|6;26;50;74;98;122|];
 47 |      [|6;30;54;78;102;126|];
 48 |      [|6;26;52;78;104;130|];
 49 |      (**)
 50 |      [|6;30;56;82;108;134|];
 51 |      [|6;34;60;86;112;138|];
 52 |      [|6;30;58;86;114;142|];
 53 |      [|6;34;62;90;118;146|];
 54 |      [|6;30;54;78;102;126;150|];
 55 |      [|6;24;50;76;102;128;154|];
 56 |      [|6;28;54;80;106;132;158|];
 57 |      [|6;32;58;84;110;136;162|];
 58 |      [|6;26;54;82;110;138;166|];
 59 |      [|6;30;58;86;114;142;170|];
 60 |   |]
 61 | 
 62 | let test_align_pats (`V version as v) =
 63 |   if version = 1 then () else
 64 |   let pat_count = Qrc.Prop.align_pat_count v in
 65 |   let pat_last = Qrc.Prop.align_pat_last v in
 66 |   let pat_delta = Qrc.Prop.align_pat_delta v in
 67 |   let p = version_align_pat.(version - 1) in
 68 |   Test.int ~__POS__ pat_count (Array.length p);
 69 |   for i = 0 to pat_count - 1 do
 70 |     Test.int ~__POS__
 71 |       (Qrc.Prop.align_pat_center ~pat_count ~pat_last ~pat_delta i) p.(i);
 72 |     Test.int ~__POS__ (p.(i) mod 2) 0; (* We rely on that during data layout. *)
 73 |  done
 74 | 
 75 | (* Capacity and error correction blocks *)
 76 | 
 77 | let ec_level_of_idx = function
 78 |   | 0 -> `L | 1 -> `M | 2 -> `Q | 3 -> `H | _ -> assert false
 79 | 
 80 | let version_total_bytes =
 81 |   (* 'Total number of codewords' in table 9, indexed by version - 1 *)
 82 |   [| 26; 44; 70; 100; 134; 172; 196; 242; 292; 346; (**)
 83 |      404; 466; 532; 581; 655; 733; 815; 901; 991; 1085; (**)
 84 |      1156; 1258; 1364; 1474; 1588; 1706; 1828; 1921; 2051; (**)
 85 |      2185; 2323; 2465; 2611; 2761; 2876; 3034; 3196; 3362; 3532; 3706; |]
 86 | 
 87 | let test_total_bytes (`V v as version) =
 88 |   Test.int ~__POS__ (Qrc.Prop.total_bytes version) (version_total_bytes.(v -1))
 89 | 
 90 | let version_data_bytes =
 91 |   (* 'Number of data codewords' in table 7, indexed by version - 1 and
 92 |      ec level. *)
 93 |   [| [|19;16;13;9|];
 94 |      [|34;28;22;16|];
 95 |      [|55;44;34;26|];
 96 |      [|80;64;48;36|];
 97 |      [|108;86;62;46|];
 98 |      [|136;108;76;60|];
 99 |      [|156;124;88;66|];
100 |      [|194;154;110;86|];
101 |      [|232;182;132;100|];
102 |      [|274;216;154;122|];
103 |      (**)
104 |      [|324;254;180;140|];
105 |      [|370;290;206;158|];
106 |      [|428;334;244;180|];
107 |      [|461;365;261;197|];
108 |      [|523;415;295;223|];
109 |      [|589;453;325;253|];
110 |      [|647;507;367;283|];
111 |      [|721;563;397;313|];
112 |      [|795;627;445;341|];
113 |      [|861;669;485;385|];
114 |      (**)
115 |      [|932;714;512;406|];
116 |      [|1006;782;568;442|];
117 |      [|1094;860;614;464|];
118 |      [|1174;914;664;514|];
119 |      [|1276;1000;718;538|];
120 |      [|1370;1062;754;596|];
121 |      [|1468;1128;808;628|];
122 |      [|1531;1193;871;661|];
123 |      [|1631;1267;911;701|];
124 |      [|1735;1373;985;745|];
125 |      (**)
126 |      [|1843;1455;1033;793|];
127 |      [|1955;1541;1115;845|];
128 |      [|2071;1631;1171;901|];
129 |      [|2191;1725;1231;961|];
130 |      [|2306;1812;1286;986|];
131 |      [|2434;1914;1354;1054|];
132 |      [|2566;1992;1426;1096|];
133 |      [|2702;2102;1502;1142|];
134 |      [|2812;2216;1582;1222|];
135 |      [|2956;2334;1666;1276|] |]
136 | 
137 | let test_data_bytes (`V v as version) ec_level_idx =
138 |   Test.int ~__POS__
139 |     (Qrc.Prop.data_bytes version (ec_level_of_idx ec_level_idx))
140 |     version_data_bytes.(v - 1).(ec_level_idx)
141 | 
142 | let version_block_spec = (* Table 9 *)
143 |   (* From table 9, 'Number of error correction blocks',
144 |      'total codewords (c)', 'data codewords (k)' once (only 1 group)
145 |      or twice (two groups). Indexed by version-1 and ec_level *)
146 |   [|
147 |     [| [|1; 26; 19|]; [|1; 26; 16|]; [|1; 26; 13|]; [|1; 26; 9|]; |];
148 |     [| [|1; 44; 34|]; [|1; 44; 28|]; [|1; 44; 22|]; [|1; 44; 16|]; |];
149 |     [| [|1; 70; 55|]; [|1; 70; 44|]; [|2; 35; 17|]; [|2; 35; 13|]; |];
150 |     [| [|1; 100; 80|]; [|2; 50; 32|]; [|2; 50; 24|]; [|4; 25; 9|]; |];
151 |     [| [|1; 134; 108|]; [|2; 67; 43|]; [|2; 33; 15; 2; 34; 16|];
152 |        [|2; 33; 11; 2; 34; 12|]; |];
153 |     [| [|2; 86; 68|]; [|4; 43; 27|]; [|4; 43; 19|]; [|4; 43; 15|]; |];
154 |     [| [|2; 98; 78|]; [|4; 49; 31|]; [|2; 32; 14; 4; 33; 15|];
155 |        [|4; 39; 13; 1; 40; 14|] |];
156 |     [| [|2; 121; 97|]; [|2; 60; 38; 2; 61; 39|];
157 |        [|4; 40; 18; 2; 41; 19|]; [|4; 40; 14; 2; 41; 15|]; |];
158 |     [| [|2; 146; 116|]; [|3; 58; 36; 2; 59; 37|]; [|4; 36; 16; 4; 37; 17|];
159 |        [|4; 36; 12; 4; 37; 13|]; |];
160 |     [| [|2; 86; 68; 2; 87; 69|]; [|4; 69; 43; 1; 70; 44|];
161 |        [|6; 43; 19; 2; 44; 20|]; [|6; 43; 15; 2; 44; 16|]; |];
162 |     (**)
163 |     [| [|4; 101; 81|]; [|1; 80; 50; 4; 81; 51|]; [|4; 50; 22; 4; 51; 23|];
164 |        [|3; 36; 12; 8; 37; 13|]; |];
165 |     [| [|2; 116; 92; 2; 117; 93|]; [|6; 58; 36; 2; 59; 37|];
166 |        [|4; 46; 20; 6; 47; 21|]; [|7; 42; 14; 4; 43; 15|]; |];
167 |     [| [|4; 133; 107|]; [|8; 59; 37; 1; 60; 38|];
168 |        [|8; 44; 20; 4; 45; 21|]; [|12; 33; 11; 4; 34; 12|]; |];
169 |     [| [|3; 145; 115; 1; 146; 116|]; [|4; 64; 40; 5; 65; 41|];
170 |        [|11; 36; 16; 5; 37; 17|]; [|11; 36; 12; 5; 37; 13|]; |];
171 |     [| [|5; 109; 87; 1; 110; 88|]; [|5; 65; 41; 5; 66; 42|];
172 |        [|5; 54; 24; 7; 55; 25|]; [|11; 36; 12; 7; 37; 13|]; |];
173 |     [| [|5; 122; 98; 1; 123; 99|]; [|7; 73; 45; 3; 74; 46|];
174 |        [|15; 43; 19; 2; 44; 20|]; [|3; 45; 15; 13; 46; 16|]; |];
175 |     [| [|1; 135; 107; 5; 136; 108|]; [|10; 74; 46; 1; 75; 47|];
176 |        [|1; 50; 22; 15; 51; 23|]; [|2; 42; 14; 17; 43; 15|] |];
177 |     [| [|5; 150; 120; 1; 151; 121|]; [|9; 69; 43; 4; 70; 44|];
178 |        [|17; 50; 22; 1; 51; 23|]; [|2; 42; 14; 19; 43; 15|]; |];
179 |     [| [|3; 141; 113; 4; 142; 114|]; [|3; 70; 44; 11; 71; 45|];
180 |        [|17; 47; 21; 4; 48; 22|]; [|9; 39; 13; 16; 40; 14|]; |];
181 |     [| [|3; 135; 107; 5; 136; 108|]; [|3; 67; 41; 13; 68; 42|];
182 |        [|15; 54; 24; 5; 55; 25|]; [|15; 43; 15; 10; 44; 16|]; |];
183 |     (**)
184 |     [| [|4; 144; 116; 4; 145; 117|]; [|17; 68; 42|];
185 |        [|17; 50; 22; 6; 51; 23|]; [|19; 46; 16; 6; 47; 17|]; |];
186 |     [| [|2; 139; 111; 7; 140; 112|]; [|17; 74; 46|]; [|7; 54; 24; 16; 55; 25|];
187 |        [|34; 37; 13|]; |];
188 |     [| [|4; 151; 121; 5; 152; 122|]; [|4; 75; 47; 14; 76; 48|];
189 |        [|11; 54; 24; 14; 55; 25|]; [|16; 45; 15; 14; 46; 16|]; |];
190 |     [| [|6; 147; 117; 4; 148; 118|]; [|6; 73; 45; 14; 74; 46|];
191 |        [|11; 54; 24; 16; 55; 25|]; [|30; 46; 16; 2; 47; 17|] |];
192 |     [| [|8; 132; 106; 4; 133; 107|]; [|8; 75; 47; 13; 76; 48|];
193 |        [|7; 54; 24; 22; 55; 25|]; [|22; 45; 15; 13; 46; 16|]; |];
194 |     [| [|10; 142; 114; 2; 143; 115|]; [|19; 74; 46; 4; 75; 47|];
195 |        [|28; 50; 22; 6; 51; 23|]; [|33; 46; 16; 4; 47; 17|]; |];
196 |     [| [|8; 152; 122; 4; 153; 123|]; [|22; 73; 45; 3; 74; 46|];
197 |        [|8; 53; 23; 26; 54; 24|]; [|12; 45; 15; 28; 46; 16|]; |];
198 |     [| [|3; 147; 117; 10; 148; 118|]; [|3; 73; 45; 23; 74; 46|];
199 |        [|4; 54; 24; 31; 55; 25|]; [|11; 45; 15; 31; 46; 16|]; |];
200 |     [| [|7; 146; 116; 7; 147; 117|]; [|21; 73; 45; 7; 74; 46|];
201 |        [|1; 53; 23; 37; 54; 24|]; [|19; 45; 15; 26; 46; 16|]; |];
202 |     [| [|5; 145; 115; 10; 146; 116|]; [|19; 75; 47; 10; 76; 48|];
203 |        [|15; 54; 24; 25; 55; 25|]; [|23; 45; 15; 25; 46; 16|]; |];
204 |     (**)
205 |     [| [|13; 145; 115; 3; 146; 116|]; [|2; 74; 46; 29; 75; 47|];
206 |        [|42; 54; 24; 1; 55; 25|]; [|23; 45; 15; 28; 46; 16|]; |];
207 |     [| [|17; 145; 115|]; [|10; 74; 46; 23; 75; 47|];
208 |        [|10; 54; 24; 35; 55; 25|]; [|19; 45; 15; 35; 46; 16|]; |];
209 |     [| [|17; 145; 115; 1; 146; 116|]; [|14; 74; 46; 21; 75; 47|];
210 |        [|29; 54; 24; 19; 55; 25|]; [|11; 45; 15; 46; 46; 16|]; |];
211 |     [| [|13; 145; 115; 6; 146; 116|]; [|14; 74; 46; 23; 75; 47|];
212 |        [|44; 54; 24; 7; 55; 25|]; [|59; 46; 16; 1; 47; 17|]; |];
213 |     [| [|12; 151; 121; 7; 152; 122|]; [|12; 75; 47; 26; 76; 48|];
214 |        [|39; 54; 24; 14; 55; 25|]; [|22; 45; 15; 41; 46; 16|]; |];
215 |     [| [|6; 151; 121; 14; 152; 122|]; [|6; 75; 47; 34; 76; 48|];
216 |        [|46; 54; 24; 10; 55; 25|]; [|2; 45; 15; 64; 46; 16|]; |];
217 |     [| [|17; 152; 122; 4; 153; 123|]; [|29; 74; 46; 14; 75; 47|];
218 |        [|49; 54; 24; 10; 55; 25|]; [|24; 45; 15; 46; 46; 16|]; |];
219 |     [| [|4; 152; 122; 18; 153; 123|]; [|13; 74; 46; 32; 75; 47|];
220 |        [|48; 54; 24; 14; 55; 25|]; [|42; 45; 15; 32; 46; 16|]; |];
221 |     [| [|20; 147; 117; 4; 148; 118|]; [|40; 75; 47; 7; 76; 48|];
222 |        [|43; 54; 24; 22; 55; 25|]; [|10; 45; 15; 67; 46; 16|]; |];
223 |     [| [|19; 148; 118; 6; 149; 119|]; [|18; 75; 47; 31; 76; 48|];
224 |        [|34; 54; 24; 34; 55; 25|]; [|20; 45; 15; 61; 46; 16|]; |]
225 |   |]
226 | 
227 | type block_spec =
228 |   { ec_bytes_per_block : int;
229 |     g1_blocks : int;
230 |     g1_data_bytes : int;
231 |     g2_blocks : int; (* Those are larger by 1 *)
232 |     g2_data_bytes : int }
233 | 
234 | let block_spec v ec_level =
235 |   let dm = Qrc.Prop.total_bytes v in
236 |   let blocks = Qrc.Prop.ec_blocks v ec_level in
237 |   let ec_bytes_per_block = Qrc.Prop.ec_bytes v ec_level / blocks in
238 |   let g1_blocks = blocks - (dm mod blocks) in
239 |   let g2_blocks = dm mod blocks in
240 |   let g1_data_bytes = (dm / blocks) - ec_bytes_per_block in
241 |   let g2_data_bytes = if g2_blocks = 0 then 0 else g1_data_bytes + 1
242 |   in
243 |   { ec_bytes_per_block;
244 |     g1_blocks; g1_data_bytes;
245 |     g2_blocks; g2_data_bytes; }
246 | 
247 | let test_block_spec (`V v as version) ec_level_idx =
248 |   let ec_level = ec_level_of_idx ec_level_idx in
249 |   let f = version_block_spec.(v - 1).(ec_level_idx) in
250 |   let b = block_spec version ec_level in
251 |   Test.int ~__POS__ f.(0) b.g1_blocks;
252 |   Test.int ~__POS__ f.(1) (b.g1_data_bytes + b.ec_bytes_per_block);
253 |   Test.int ~__POS__ f.(2) b.g1_data_bytes;
254 |   if b.g2_blocks = 0 then Test.int ~__POS__ (Array.length f) 3 else
255 |   begin
256 |     Test.int ~__POS__ f.(3) b.g2_blocks;
257 |     Test.int ~__POS__ f.(4) (b.g2_data_bytes + b.ec_bytes_per_block);
258 |     Test.int ~__POS__ f.(5) b.g2_data_bytes;
259 |   end
260 | 
261 | let test_version_props =
262 |   Test.test "version properties" @@ fun () ->
263 |   Test.range ~kind:"Version" ~first:1 ~last:40 @@ fun v ->
264 |   let v = `V v in
265 |   test_align_pats v;
266 |   test_total_bytes v;
267 |   for ec_level = 0 to 3 do
268 |     test_data_bytes v ec_level;
269 |     test_block_spec v ec_level;
270 |   done
271 | 
272 | (* Galois field and Reed-Solomon generator polynomials *)
273 | 
274 | let test_gf_256 =
275 |   Test.test "Galois field arithmetic" @@ fun () ->
276 |   let module Gf_256 = Qrc.Gf_256 in
277 |   let f = Lazy.force Qrc.Prop.field in
278 |   for i = 0 to 254 do
279 |     Test.int ~__POS__ (Gf_256.log f (Gf_256.exp f i)) i;
280 |     Test.int ~__POS__ (Gf_256.log f (Gf_256.exp f (i + 255))) i;
281 |   done;
282 |   for i = 1 to 255 do
283 |     Test.int ~__POS__ (Gf_256.exp f (Gf_256.log f i)) i;
284 |     Test.int ~__POS__ (Gf_256.mul f i (Gf_256.inv f i)) 1;
285 |   done;
286 |   Test.int ~__POS__ (Gf_256.exp f 0) 1;
287 |   Test.int ~__POS__ (Gf_256.log f 0) 255;
288 |   Test.int ~__POS__ (Gf_256.inv f 0) 0;
289 |   ()
290 | 
291 | let generator_polynomial_exps =
292 |   (* Table A.1, 'Number of error correction codewords',
293 |      'Generator polynomial' (exponents, the coefficient is 2^e)
294 |      Trimmed to to actual number of error correction bytes used in QR codes. *)
295 |   [
296 |     7,  [|0; 87; 229; 146; 149; 238; 102; 21|];
297 |     10, [|0; 251; 67; 46; 61; 118; 70; 64; 94; 32; 45|];
298 |     13, [|0; 74; 152; 176; 100; 86; 100; 106; 104; 130; 218; 206; 140; 78|];
299 |     15, [|0; 8; 183; 61; 91; 202; 37; 51; 58; 58; 237; 140; 124; 5; 99; 105|];
300 |     16, [|0; 120; 104; 107; 109; 102; 161; 76; 3; 91; 191; 147; 169; 182; 194;
301 |           225; 120|];
302 |     17, [|0; 43; 139; 206; 78; 43; 239; 123; 206; 214; 147; 24; 99; 150; 39;
303 |           243; 163; 136|];
304 |     18, [|0; 215; 234; 158; 94; 184; 97; 118; 170; 79; 187; 152; 148; 252;
305 |           179; 5; 98; 96; 153|];
306 |     20, [|0; 17; 60; 79; 50; 61; 163; 26; 187; 202; 180; 221; 225; 83; 239; 156;
307 |           164; 212; 212; 188; 190|];
308 |     22, [|0; 210; 171; 247; 242; 93; 230; 14; 109; 221; 53; 200; 74; 8; 172; 98;
309 |           80; 219; 134; 160; 105; 165; 231|];
310 |     24, [|0; 229; 121; 135; 48; 211; 117; 251; 126; 159; 180; 169; 152; 192;
311 |           226; 228; 218; 111; 0; 117; 232; 87; 96; 227; 21|];
312 |     26, [|0; 173; 125; 158; 2; 103; 182; 118; 17; 145; 201; 111; 28; 165; 53;
313 |           161; 21; 245; 142; 13; 102; 48; 227; 153; 145; 218; 70|];
314 |     28, [|0; 168; 223; 200; 104; 224; 234; 108; 180; 110; 190; 195; 147; 205;
315 |           27; 232; 201; 21; 43; 245; 87; 42; 195; 212; 119; 242; 37; 9; 123|];
316 |     30, [|0; 41; 173; 145; 152; 216; 31; 179; 182; 50; 48; 110; 86; 239; 96;
317 |           222; 125; 42; 173; 226; 193; 224; 130; 156; 37; 251; 216; 238; 40;
318 |           192; 180|]
319 |   ]
320 | 
321 | let test_generator_polynomials =
322 |   Test.test "generator polynomials" @@ fun () ->
323 |   let field = Lazy.force Qrc.Prop.field in
324 |   let of_exp (ec, exps) = ec, Array.map (Qrc.Gf_256.exp field) exps in
325 |   let gens = List.map of_exp generator_polynomial_exps in
326 |   let ec_dom = (* Check we only use these [ec] byte counts *)
327 |     let module Iset = Set.Make (Int) in
328 |     let acc = ref Iset.empty in
329 |     for v = 1 to 40 do
330 |       for ec_level = 0 to 3 do
331 |         let ec_level = ec_level_of_idx ec_level in
332 |         let ec_bytes = Qrc.Prop.ec_bytes (`V v) ec_level in
333 |         let ec_blocks = Qrc.Prop.ec_blocks (`V v) ec_level in
334 |         acc := Iset.add (ec_bytes / ec_blocks) !acc
335 |       done
336 |     done;
337 |     Iset.elements !acc
338 |   in
339 |   let gens' = List.map (fun ec -> ec, Qrc.Prop.gen field ~ec) ec_dom in
340 |   Test.(list T.any) gens gens' ~__POS__;
341 |   ()
342 | 
343 | let main () = Test.main @@ fun () -> Test.autorun ()
344 | let () = if !Sys.interactive then () else exit (main ())
345 | 


--------------------------------------------------------------------------------
/src/qrc.ml:
--------------------------------------------------------------------------------
  1 | (*---------------------------------------------------------------------------
  2 |    Copyright (c) 2020 The qrc programmers. All rights reserved.
  3 |    SPDX-License-Identifier: ISC
  4 |   ---------------------------------------------------------------------------*)
  5 | 
  6 | (* Any mention of section, figure or table refers to the ISO/IEC 18004:2015(E)
  7 |    standard. *)
  8 | 
  9 | let div_round_up x y = (x + y - 1) / y
 10 | 
 11 | (* Sequences of bytes. We use bigarrays to get typed array in js_of_ocaml *)
 12 | 
 13 | module Bytes = struct
 14 |   type t = (int,Bigarray.int8_unsigned_elt,Bigarray.c_layout) Bigarray.Array1.t
 15 |   let _create len = Bigarray.(Array1.create int8_unsigned c_layout len)
 16 |   let create ~len v = let a = _create len in Bigarray.Array1.fill a v; a
 17 |   let length b = Bigarray.Array1.dim b
 18 |   let get = (Bigarray.Array1.get : t -> int -> int)
 19 |   let set = (Bigarray.Array1.set : t -> int -> int -> unit)
 20 |   let copy b = let c = _create (length b) in Bigarray.Array1.blit b c; c
 21 |   let blit ~src si ~dst di ~len =
 22 |     let src = Bigarray.Array1.sub src si len in
 23 |     let dst = Bigarray.Array1.sub dst di len in
 24 |     Bigarray.Array1.blit src dst
 25 | end
 26 | 
 27 | (* Sequences of bits. *)
 28 | 
 29 | module Bits = struct
 30 |   type t = Bytes.t
 31 |   let create len v =
 32 |     Bytes.create ~len:(div_round_up len 8) (if v then 255 else 0)
 33 | 
 34 |   let length b = (Bytes.length b) * 8
 35 |   let copy = Bytes.copy
 36 |   let[@inline] get bits i =
 37 |     let i_byte = i / 8 in
 38 |     let bit_mask = 1 lsl (7 - i mod 8) in
 39 |     (Bytes.get bits i_byte) land bit_mask > 0
 40 | 
 41 |   let[@inline] set bits i v =
 42 |     let i_byte = i / 8 in
 43 |     let byte = Bytes.get bits i_byte in
 44 |     let bit_mask = 1 lsl (7 - i mod 8) in
 45 |     let byte' = if v then byte lor bit_mask else byte land (lnot bit_mask) in
 46 |     Bytes.set bits i_byte byte'
 47 | end
 48 | 
 49 | (* Galois fields and Reed-Solomon encoding
 50 | 
 51 |    Follows the treatement found at https://research.swtch.com/field, see also
 52 |    https://en.wikipedia.org/wiki/Finite_field_arithmetic#Implementation_tricks*)
 53 | module Gf_256 = struct
 54 |   type poly = int
 55 |   type byte = int
 56 |   type t =
 57 |     { log : byte array; (* 256 els *)
 58 |       exp : byte array; (* 510 els, twice the same data to avoid mod in mul *) }
 59 | 
 60 |   let mul x y ~mod' = (* slow, only used to generate the exp table *)
 61 |     let z = ref 0 and x = ref x and y = ref y in
 62 |     while (!x > 0) do
 63 |       if !x land 1 = 1 then z := !z lxor !y; (* add *)
 64 |       x := !x lsr 1;
 65 |       y := !y lsl 1;
 66 |       if !y land 0x100 <> 0 then (* exceeds deg 7 *) y := !y lxor mod' (* sub *)
 67 |     done;
 68 |     !z
 69 | 
 70 |   let create ~r ~g =
 71 |     let f = { log = Array.make 256 0; exp = Array.make 510 0 } in
 72 |     let x = ref 1 (* g ^ 0 *) in
 73 |     for i = 0 to 254 do
 74 |       (* The exp table is doubled to avoid a mod 255 in mul below *)
 75 |       f.exp.(i) <- !x; f.exp.(i + 255) <- !x;
 76 |       f.log.(!x) <- i;
 77 |       x := mul !x g ~mod':r
 78 |     done;
 79 |     f.log.(0) <- 255;
 80 |     f
 81 | 
 82 |   let[@inline] add x y = x lxor y
 83 |   let[@inline] sub x y = x lxor y
 84 |   let[@inline] exp f x = f.exp.(x mod 255)
 85 |   let[@inline] log f x = f.log.(x)
 86 |   let[@inline] inv f x = if x = 0 then 0 else f.exp.(255 - f.log.(x))
 87 |   let[@inline] mul f x y =
 88 |     if x = 0 || y = 0 then 0 else f.exp.(f.log.(x) + f.log.(y))
 89 | end
 90 | 
 91 | module Rs = struct
 92 |   type gen = int array (* Generator polynomial coefficients (hi to lo). *)
 93 | 
 94 |   (* Generates a polynomial for [ec] error correction bytes. Given [g] the
 95 |      generator of [f] this computes the coefficients of the polynomial:
 96 |      gen(x) = (x - g^0)(x - g^1)(x - g^ec) *)
 97 |   let gen f ~ec : gen =
 98 |     let gen = Array.make (ec + 1) 0 in
 99 |     gen.(ec) <- 1; (* gen := 1 *)
100 |     for i = 0 to ec - 1 do (* do gen := gen * (x - g^i) *)
101 |       let gi = Gf_256.exp f i in
102 |       for j = 0 to ec - 1 do
103 |         gen.(j) <- Gf_256.sub gen.(j + 1) (Gf_256.mul f gen.(j) gi)
104 |       done;
105 |       gen.(ec) <- Gf_256.mul f gen.(ec) gi (* g^0 * g^1 * ... * g^ec *)
106 |     done;
107 |     gen
108 | 
109 |   (* The following function computes the remainder of [p], the message
110 |      padded with [ec] zero bytes, divided by [gen] by repeatedly
111 |      subtracting multiples of [gen].
112 | 
113 |     let encode f ~ec ~gen p =
114 |       for i = 0 to Bytes.length p - ec - 1 (* iterate on message bytes *) do
115 |         (* do p := p - (p.(i) / gen.(0)) * gen  *)
116 |         let k = Gf_256.mul f (Bytes.get p i) (Gf_256.inv f gen.(0)) in
117 |         for j = 0 to Array.length gen - 1 do
118 |           let ci = i + j in
119 |           let c = Bytes.get p ci in
120 |           Bytes.set p ci (Gf_256.sub c (Gf_256.mul f k gen.(j)))
121 |         done
122 |       done
123 | 
124 |      If we shortcut when [pi = 0] and [gen.(j) = 0], note that gen.(0) is
125 |      always 1, inline definitions and simplify we get to the different
126 |      more efficient function below, which works directly on the log
127 |      of [gen]'s coefficients. *)
128 | 
129 |   let log_gen f ~ec =
130 |     let gen = gen f ~ec in
131 |     for i = 0 to ec do gen.(i) <- Gf_256.log f gen.(i) done;
132 |     gen
133 | 
134 |   let encode (f : Gf_256.t) ~ec ~log_gen p =
135 |     for i = 0 to Bytes.length p - ec - 1 do
136 |       let pi = Bytes.get p i in
137 |       if pi = 0 then () else
138 |       let log_k = f.log.(pi) in
139 |       for j = 0 to Array.length log_gen - 1 do
140 |         let log_genj = log_gen.(j) in
141 |         if log_genj = 255 (* => gen.(j) = 0 *) then () else
142 |         let ci = i + j in
143 |         let c = Bytes.get p ci in
144 |         Bytes.set p ci (Gf_256.sub c (f.exp.(log_k + log_genj)))
145 |       done
146 |     done
147 | end
148 | 
149 | (* QR matrices *)
150 | 
151 | module Matrix = struct
152 |   type bits = Bits.t
153 |   type t = { w : int; bits : bits; }
154 |   let zero ~w = let bits = Bits.create (w * w) false in { w; bits }
155 |   let copy m = { m with bits = Bits.copy m.bits }
156 |   let of_bits ~w bits =
157 |     let len = div_round_up (w * w) 8 in
158 |     if Bits.length bits >= len then { w; bits } else
159 |     invalid_arg "Not enough bits provided"
160 | 
161 |   let w m = m.w
162 |   let bits m = m.bits
163 |   let[@inline] get m ~x ~y = Bits.get m.bits ((y * m.w) + x)
164 |   let[@inline] _set m ~x ~y v = Bits.set m.bits ((y * m.w) + x) v
165 |   let[@inline] set m ~x ~y = _set m ~x ~y true
166 |   let[@inline] clear m ~x ~y = _set m ~x ~y false
167 |   let fold f m acc =
168 |     let acc = ref acc in
169 |     for y = 0 to m.w - 1 do
170 |       for x = 0 to m.w - 1 do acc := f x y (get m ~x ~y) !acc done
171 |     done;
172 |     !acc
173 | 
174 |   let set_square_frame m ~x ~y (* top-left corner *) ~w =
175 |     let xmin = x and ymin = y and xmax = x + w - 1 and ymax = y + w - 1 in
176 |     for x = xmin to xmax do set m ~x ~y:ymin done; (* top seg *)
177 |     for x = xmin to xmax do set m ~x ~y:ymax done; (* bot seg *)
178 |     for y = ymin + 1 to ymax - 1 do set m ~x:xmin ~y done; (* left seg *)
179 |     for y = ymin + 1 to ymax - 1 do set m ~x:xmax ~y done (* right seg *)
180 | 
181 |   let to_svg ?(w_mm = 50) ?(invert = false) ?(quiet_zone = true) m =
182 |     let w_mm = string_of_int w_mm in
183 |     let w = string_of_int @@ if quiet_zone then m.w + 8 else m.w in
184 |     let on, off = if invert then "white", "black" else "black", "white" in
185 |     let ( ++ ) acc d = d :: acc in
186 |     let acc =
187 |       [] ++ "<svg xmlns='http://www.w3.org/2000/svg' version='1.1' " ++
188 |       "width='" ++ w_mm ++ "mm' " ++ "height='" ++ w_mm ++ "mm' " ++
189 |       "viewBox='0 0 " ++ w ++ " " ++ w ++ "'>\n" ++
190 |       " <rect width='" ++ w ++ "' height='" ++ w ++ "' fill='" ++ off ++
191 |       "'/>" ++ " <path fill='" ++ on ++ "' d='"
192 |     in
193 |     let on ~x ~y acc =
194 |       acc ++ "\n M " ++ string_of_int x ++ "," ++
195 |       string_of_int y ++ " l 1,0 0,1 -1,0 z"
196 |     in
197 |     let acc = ref acc in
198 |     let pad = if quiet_zone then 4 else 0 in
199 |     for y = 0 to m.w - 1 do
200 |       for x = 0 to m.w - 1 do
201 |         if (get m ~x ~y) then (acc := on ~x:(pad + x) ~y:(pad + y) !acc)
202 |       done;
203 |     done;
204 |     String.concat "" (List.rev (!acc ++ "\n' /></svg>"))
205 | end
206 | 
207 | (* QR code properties *)
208 | 
209 | type version = [ `V of int ]
210 | type mode = [ `Byte ]
211 | type ec_level = [ `L | `M | `Q | `H ]
212 | 
213 | module Prop = struct
214 |   let version_min = 1
215 |   let version_max = 40
216 |   let version_to_w = function `V v -> 21 + 4 * (v - 1)
217 |   let version_of_w w =
218 |     let err w = Error ("QR code width cannot be " ^ string_of_int w) in
219 |     match w with
220 |     | w when 21 <= w && w <= 177 ->
221 |         let base = w - 21 in
222 |         if base mod 4 <> 0 then err w else Ok (`V (base / 4 + 1))
223 |     | w -> err w
224 | 
225 |   (* Alignement patterns, functions allow to recover the data of table E.1 in
226 |      N.B. this assumes version > 1 *)
227 | 
228 |   let align_pat_count (`V v) = (* along one dimension *) (v / 7) + 2
229 |   let align_pat_first = 6
230 |   let align_pat_last v = version_to_w v - 7
231 |   let align_pat_delta (`V version as v) =
232 |     (* center to center distance from right to left or bottom up. The last
233 |        hop to column/row 6 absorbs the unevenness. *)
234 |     if version = 32 then 26 (* odd exception: we compute 28 *) else
235 |     let s = (align_pat_last v - align_pat_first) in
236 |     let d = div_round_up s (align_pat_count v - 1) in
237 |     if d mod 2 = 1 then d + 1 else d
238 | 
239 |   let align_pat_center ~pat_count ~pat_last ~pat_delta i =
240 |     (* ith pattern from left to right or top to botom  *)
241 |     if i = 0 then 6 else pat_last - pat_delta * ((pat_count - 1) - i)
242 | 
243 |   (* Capacity *)
244 | 
245 |   let total_modules (`V version as v) =
246 |     (* 'Data modules except (C)' in table 1 *)
247 |     let version_w = version_to_w v in
248 |     let all_mods = version_w * version_w in
249 |     let finder_mods = 3 * 64 in
250 |     let timing_mods = 2 * (version_w - 16) in
251 |     let align_pats_mods =
252 |       if version = 1 then 0 else
253 |       let align_pat_count = align_pat_count v in
254 |       let align_pats = max 1 ((align_pat_count * align_pat_count) - 3) in
255 |       let align_pats_and_timing_overlap = 2 * (5 * (align_pat_count - 2)) in
256 |       align_pats * 25 - align_pats_and_timing_overlap
257 |     in
258 |     let version_mods = if version >= 7 then 2 * 18 else 0 in
259 |     let format_info_mods = 2 * 15 in
260 |     let lone_dark_mod = 1 in (* see figure 25 *)
261 |     all_mods - finder_mods - timing_mods - align_pats_mods - version_mods -
262 |     format_info_mods - lone_dark_mod
263 | 
264 |   let total_bytes v =
265 |     (* 'Total number of codewords' in table 9  *)
266 |     (total_modules v) / 8
267 | 
268 |   (* Error correction block specification, per ec level.
269 | 
270 |      Given the number of ec codeword per level and the number of blocks.
271 |      We can recover the number of data code words per block and the block
272 |      layout (first group and potentially second group with one more byte). *)
273 | 
274 |   let ec_level_idx = function `L -> 0 | `M -> 1 | `Q -> 2 | `H -> 3
275 |   let ec_block_spec =
276 |     (* Table 9, 'Number of error correction codewords' and
277 |        'Number of error correction blocks' by increasing version and ec_level.
278 |        This is the only property we did not manage to derive from structural
279 |        principles of QR codes. *)
280 |     [| 7;1; 10;1; 13;1; 17;1;
281 |        10;1; 16;1; 22;1; 28;1;
282 |        15;1; 26;1; 36;2; 44;2;
283 |        20;1; 36;2; 52;2; 64;4;
284 |        26;1; 48;2; 72;4; 88;4;
285 |        36;2; 64;4; 96;4; 112;4;
286 |        40;2; 72;4; 108;6; 130;5;
287 |        48;2; 88;4; 132;6; 156;6;
288 |        60;2; 110;5; 160;8; 192;8;
289 |        72;4; 130;5; 192;8; 224;8;
290 |        (* *)
291 |        80;4; 150;5; 224;8; 264;11;
292 |        96;4; 176;8; 260;10; 308;11;
293 |        104;4; 198;9; 288;12; 352;16;
294 |        120;4; 216;9; 320;16; 384;16;
295 |        132;6; 240;10; 360;12; 432;18;
296 |        144;6; 280;10; 408;17; 480;16;
297 |        168;6; 308;11; 448;16; 532;19;
298 |        180;6; 338;13; 504;18; 588;21;
299 |        196;7; 364;14; 546;21; 650;25;
300 |        224;8; 416;16; 600;20; 700;25;
301 |        (* *)
302 |        224;8; 442;17; 644;23; 750;25;
303 |        252;9; 476;17; 690;23; 816;34;
304 |        270;9; 504;18; 750;25; 900;30;
305 |        300;10; 560;20; 810;27; 960;32;
306 |        312;12; 588;21; 870;29; 1050;35;
307 |        336;12; 644;23; 952;34; 1110;37;
308 |        360;12; 700;25; 1020;34; 1200;40;
309 |        390;13; 728;26; 1050;35; 1260;42;
310 |        420;14; 784;28; 1140;38; 1350;45;
311 |        450;15; 812;29; 1200;40; 1440;48;
312 |        (* *)
313 |        480;16; 868;31; 1290;43; 1530;51;
314 |        510;17; 924;33; 1350;45; 1620;54;
315 |        540;18; 980;35; 1440;48; 1710;57;
316 |        570;19; 1036;37; 1530;51; 1800;60;
317 |        570;19; 1064;38; 1590;53; 1890;63;
318 |        600;20; 1120;40; 1680;56; 1980;66;
319 |        630;21; 1204;43; 1770;59; 2100;70;
320 |        660;22; 1260;45; 1860;62; 2220;74;
321 |        720;24; 1316;47; 1950;65; 2310;77;
322 |        750;25; 1372;49; 2040;68; 2430;81; |]
323 | 
324 |   let ec_bytes (`V version) ec_level =
325 |     (* 'Number of error correction codewords' in table 9 *)
326 |     ec_block_spec.((version - 1) * 8 + 2 * (ec_level_idx ec_level))
327 | 
328 |   let ec_blocks (`V version) ec_level =
329 |     (* 'Number of error correction blocks' in table 9 *)
330 |     ec_block_spec.((version - 1) * 8 + 2 * (ec_level_idx ec_level) + 1)
331 | 
332 |   let data_bytes version ec_level =
333 |     (* 'Number of data codewords' in table 7 *)
334 |     (total_bytes version) - (ec_bytes version ec_level)
335 | 
336 |   let character_count_bits (`V version) = function
337 |   | `Byte -> if version <= 9 then 8 else 16
338 | 
339 |   let mode_capacity version ec_idx mode =
340 |     (* 'Data capacity' in table 7 *)
341 |     let bits = 8 * data_bytes version ec_idx in
342 |     let bits = bits - 4 (* mode indicator *) in
343 |     let bits = bits - character_count_bits version mode  in
344 |     match mode with
345 |     | `Byte -> bits / 8
346 | 
347 |   let field = lazy (Gf_256.create ~r:0b100011101 ~g:2) (* see 7.5.2 *)
348 |   let gen field ~ec = Rs.gen field ~ec (* exposed for testing *)
349 | end
350 | 
351 | (* Encoding
352 | 
353 |    https://www.thonky.com/qr-code-tutorial/ may be useful to understand the
354 |    encoding process. *)
355 | 
356 | let encode_padding b ~first ~last = (* see 7.4.10 *)
357 |   (* Pads with alternating 236 and 17 from ~first to ~last. *)
358 |   let rec set_236 i last =
359 |     if i > last then () else (Bytes.set b i 236; set_17 (i + 1) last)
360 |   and set_17 i last =
361 |     if i > last then () else (Bytes.set b i 17; set_236 i last)
362 |   in
363 |   set_236 first last
364 | 
365 | let encode_with_byte_mode v mode ~enc_len s = (* see 7.4 and 7.4.5 *)
366 |   (* N.B. we can work around working at the bit level. Half bytes do it. *)
367 |   let len = String.length s in
368 |   let b = Bytes.create ~len:enc_len 0 in
369 |   let cc = Prop.character_count_bits v mode in
370 |   let get = Bytes.get and set = Bytes.set in
371 |   set b 0 ((0b0100_0000) (* mode indicator *)
372 |            lor (len lsr cc - 4)) (* hi four bits of len *);
373 |   let half_data_start = match cc with
374 |   | 8 ->
375 |       set b 0 (0b0100_0000 lor ((len lsr 4) land 0xF));
376 |       set b 1 ((len land 0xF) lsl 4);
377 |       1
378 |   | 16 ->
379 |       set b 0 (0b0100_0000 lor ((len lsr 12) land 0xF));
380 |       set b 1 ((len lsr 4) land 0xFF);
381 |       set b 2 ((len land 0xF) lsl 4);
382 |       2
383 |   | _ -> assert false
384 |   in
385 |   let half_data_end = half_data_start + len - 1 + 1 in
386 |   for i = 0 to len - 1 do
387 |     let v = Char.code (String.get s i) in
388 |     let k = half_data_start + i in
389 |     set b k (get b k lor ((v lsr 4) land 0xF));
390 |     set b (k + 1) ((v land 0xF) lsl 4);
391 |   done;
392 |   (* We always end up on a half-byte, add 0b0000 terminator (see 7.4.9) *)
393 |   set b half_data_end (get b half_data_end land 0xF0);
394 |   encode_padding b ~first:(half_data_end + 1) ~last:(enc_len - 1);
395 |   b
396 | 
397 | let encode_with_mode v ec_level mode s = (* see 7.4 *)
398 |   let enc_len = Prop.data_bytes v ec_level in
399 |   match mode with
400 |   | `Byte -> encode_with_byte_mode v mode ~enc_len s
401 | 
402 | (* Function modules matrix setters *)
403 | 
404 | let set_finder_patterns m = (* see 6.6.3 *)
405 |   let set_finder_pattern m ~x ~y (* top-left *) =
406 |     Matrix.set_square_frame m ~x ~y ~w:7;
407 |     Matrix.set_square_frame m ~x:(x + 2) ~y:(y + 2) ~w:3;
408 |     Matrix.set m ~x:(x + 3) ~y:(y + 3)
409 |   in
410 |   set_finder_pattern m ~x:0 ~y:0;
411 |   set_finder_pattern m ~x:0 ~y:(Matrix.w m - 7);
412 |   set_finder_pattern m ~x:(Matrix.w m - 7) ~y:0
413 | 
414 | let set_timing_patterns m = (* see 6.3.5 *)
415 |   let max = Matrix.w m - 9 in
416 |   for x = 8 to max do if x mod 2 = 0 then Matrix.set m ~x ~y:6 done;
417 |   for y = 8 to max do if y mod 2 = 0 then Matrix.set m ~x:6 ~y done
418 | 
419 | let set_alignment_patterns (`V version as v) m = (* see 6.3.6 and annex E *)
420 |   if version = 1 then () else
421 |   let alignment_pattern m ~x ~y (* top-left *) =
422 |     Matrix.set_square_frame m ~x ~y ~w:5;
423 |     Matrix.set m ~x:(x + 2) ~y:(y + 2)
424 |   in
425 |   let pat_count = Prop.align_pat_count v in
426 |   let pat_last = Prop.align_pat_last v in
427 |   let pat_delta = Prop.align_pat_delta v in
428 |   let max = pat_count - 1 in
429 |   for i = 0 to max do
430 |     for j = 0 to max do
431 |       (* skip if overlaps with finder patterns *)
432 |       if (i = 0 && j = 0) || (i = 0 && j = max) || (i = max && j = 0) then ()
433 |       else
434 |       let x = (Prop.align_pat_center ~pat_count ~pat_last ~pat_delta) i - 2 in
435 |       let y = (Prop.align_pat_center ~pat_count ~pat_last ~pat_delta) j - 2 in
436 |       alignment_pattern m ~x ~y
437 |     done
438 |   done
439 | 
440 | (* Format information matrix setter *)
441 | 
442 | let encode_format_information ec_level mask = (* see 7.9 & C.2 *)
443 |   let ec_bits = match ec_level with
444 |   | `L -> 0b01 | `M -> 0b00 | `Q -> 0b11 | `H -> 0b10
445 |   in
446 |   let data = (ec_bits lsl 13) lor (mask lsl 10) in
447 |   let g = 0b10100110111 in
448 |   let rem = ref data in
449 |   for i = 14 downto 10 do
450 |     if (!rem land (1 lsl i)) <> 0 then rem := !rem lxor (g lsl (i - 10));
451 |   done;
452 |   (data lor !rem) lxor 0b101010000010010
453 | 
454 | let set_format_information ec_level mask m = (* see 7.9 *)
455 |   let data = encode_format_information ec_level mask in
456 |   for i = 0 to 14 do
457 |     let set = (data lsr i) land 1 = 1 in
458 |     if not set then () else begin
459 |       (* set horizontally, see figure 25 *)
460 |       (if i < 8 then Matrix.set m ~x:(Matrix.w m - 1 - i) ~y:8 else
461 |        if i < 9 then Matrix.set m ~x:(15 - i) ~y:8 else
462 |        Matrix.set m ~x:(15 - i - 1) ~y:8);
463 |       (* set vertically, see figure 25 *)
464 |       (if i < 6 then Matrix.set m ~x:8 ~y:i else
465 |        if i < 8 then Matrix.set m ~x:8 ~y:(i + 1) else
466 |        Matrix.set m ~x:8 ~y:(Matrix.w m - (15 - i)))
467 |     end;
468 |   done;
469 |   Matrix.set m ~x:8 ~y:(Matrix.w m - 8) (* dark module, see figure 25 *)
470 | 
471 | (* Version information matrix setter *)
472 | 
473 | let encode_version (`V version) = (* see 7.10 & D.2 *)
474 |   let data = version lsl 12 in
475 |   let g = 0b1111100100101 in
476 |   let rem = ref data in
477 |   for i = 17 downto 12 do
478 |     if (!rem land (1 lsl i)) <> 0 then rem := !rem lxor (g lsl (i - 12));
479 |   done;
480 |   data lor !rem
481 | 
482 | let set_version_information (`V version as v) m = (* see 7.10 *)
483 |   if version < 7 then () else
484 |   let data = encode_version v in
485 |   let delta = Matrix.w m - 8 - 3 in
486 |   for i = 0 to 17 do
487 |     let set = (data lsr i) land 1 = 1 in
488 |     if not set then () else begin
489 |       let x = i mod 3 and y = i / 3 in
490 |       Matrix.set m ~x:(delta + x) ~y;  (* top right *)
491 |       Matrix.set m ~x:y ~y:(delta + x) (* bottom left *)
492 |     end
493 |   done
494 | 
495 | (* Data and error correction matrix setter *)
496 | 
497 | let encode_ec v ec_level data =
498 |   let total_bytes = Prop.total_bytes v in
499 |   let block_count = Prop.ec_blocks v ec_level in
500 |   let longer_block_count = total_bytes mod block_count in
501 |   let normal_block_count = block_count - longer_block_count in
502 |   let[@inline] is_longer_block i = i >= normal_block_count  in
503 |   let ec_len = Prop.ec_bytes v ec_level / block_count in
504 |   let data_len = (total_bytes / block_count) - ec_len in
505 |   let blocks = (* see 7.5.2 and table 9 *)
506 |     let start = ref 0 in
507 |     let create_block i =
508 |       let data_len = data_len + if (is_longer_block i) then 1 else 0 in
509 |       let block_len = data_len + ec_len in
510 |       let block = Bytes.create ~len:block_len 0 in
511 |       Bytes.blit ~src:data !start ~dst:block 0 ~len:data_len;
512 |       start := !start + data_len;
513 |       block
514 |     in
515 |     Array.init block_count create_block
516 |   in
517 |   (* Data in blocks will be zeroed by RS computation so we allocate
518 |      the data in the final bit stream now. See 7.6 and figure 15. *)
519 |   let bits = Bytes.create ~len:total_bytes 0 in
520 |   let byte = ref 0 in
521 |   for i = 0 to (data_len + 1) - 1 do
522 |     for b = 0 to block_count - 1 do
523 |       if i = data_len && not (is_longer_block b) then () else
524 |       (Bytes.set bits !byte (Bytes.get blocks.(b) i); incr byte)
525 |     done
526 |   done;
527 |   (* Compute the error correction bytes in the blocks. *)
528 |   let f = Lazy.force Prop.field in
529 |   let log_gen = Rs.log_gen f ~ec:ec_len in
530 |   Array.iter (Rs.encode f ~ec:ec_len ~log_gen) blocks;
531 |   (* Allocate the error correction data in the bit stream (figure 15) *)
532 |   for i = 0 to ec_len - 1 do
533 |     for b = 0 to block_count - 1 do
534 |       let i = Bytes.length blocks.(b) - ec_len + i in
535 |       (Bytes.set bits !byte (Bytes.get blocks.(b) i); incr byte)
536 |     done
537 |   done;
538 |   assert (!byte = total_bytes); (* check we used up all QR bytes *)
539 |   bits
540 | 
541 | let mask_fun = function (* see table 10 *)
542 | | 0 -> fun ~x ~y -> (y + x) mod 2 = 0
543 | | 1 -> fun ~x:_ ~y -> y mod 2 = 0
544 | | 2 -> fun ~x ~y:_ -> x mod 3 = 0
545 | | 3 -> fun ~x ~y -> (y + x) mod 3 = 0
546 | | 4 -> fun ~x ~y -> ((y / 2) + (x / 3)) mod 2 = 0
547 | | 5 -> fun ~x ~y -> let yx = (y * x) in (yx mod 2) + (yx mod 3) = 0
548 | | 6 -> fun ~x ~y -> let yx = (y * x) in ((yx mod 2) + (yx mod 3)) mod 2 = 0
549 | | 7 -> fun ~x ~y -> (((y + x) mod 2) + ((y * x) mod 3)) mod 2 = 0
550 | | _ -> assert false
551 | 
552 | let set_data mask (`V version as v) data m = (* see 7.7.3 *)
553 |   let mask_fun = mask_fun mask in
554 |   let w = Matrix.w m in
555 |   let skip_version_info = version >= 7 in
556 |   let[@inline] skip_function_pats ~x ~y =
557 |     (skip_version_info && (* skip version info if version >= 7 *)
558 |      ((y <= 5 && x >= w - 11) ||
559 |       (x <= 5 && y >= w - 11))) ||
560 |     y = 6 (* skip horizontal timing pattern *) ||
561 |     (y <= 8 && (x <= 8 || x >= w - 8)) (* skip top finders *) ||
562 |     (x <= 8 && y >= w - 8) (* skip bottom left finder *)
563 |   in
564 |   let max = w - 1 in
565 |   let x = ref max in
566 |   let y = ref max in
567 |   let move = ref (-1) in (* negative moves up, positive moves down *)
568 |   (* We go over the code from right to left up and down by 2-module wide
569 |      columns and allocate the data bits on data modules (remaining unused
570 |      ones are set to false). *)
571 |   let bit = ref 0 in
572 |   let bit_max = Bits.length data - 1 in
573 |   while (!x >= 0) do
574 |     while (0 <= !y && !y <= max) do
575 |       for i = 0 to 1 do (* right and left modules of column row *)
576 |         let x = !x - i in
577 |         if (skip_function_pats[@inlined]) ~x ~y:!y then () else
578 |         let skip_align_pat =
579 |           (* The left module of columns is always handled by jumps when
580 |              i = 0. This relies on the fact that pattern centers are always
581 |              even. So on the left module (i = 1) there's nothing to skip. *)
582 |           if i = 1 then false else
583 |           if not (Matrix.get ~x ~y:!y m) then false else
584 |           (* We hit an alignment pattern. *)
585 |           let left = Matrix.get ~x:(x - 1) ~y:!y m in
586 |           (* If left is also [true] we are not on the left edge of the
587 |              the pattern so we skip the pattern height for the column
588 |              and proceed directly with the new column row (for that
589 |              row skip_base_function_patterns is guaranteed to be [false]). *)
590 |           if left then (y := !y + 5 * !move; false) else
591 |           true (* just skip the edge for the right module of the column. *)
592 |         in
593 |         if skip_align_pat then () else
594 |         let v = if !bit <= bit_max then Bits.get data !bit else false in
595 |         let v = if mask_fun ~x ~y:!y then not v else v in
596 |         if v then Matrix.set ~x ~y:!y m;
597 |         incr bit;
598 |       done;
599 |       y := !y + !move;
600 |     done;
601 |     x := !x - 2; (* next 2-module wide column *)
602 |     if !x = 6 then decr x; (* skip vertical timing pattern. *)
603 |     move := !move * -1; y := !y + !move; (* switch direction *)
604 |   done;
605 |   assert (!bit = Prop.total_modules v); (* check we used up all QR modules *)
606 |   ()
607 | 
608 | (* Matrix penalty computation, section 7.8.3.1. *)
609 | 
610 | let[@inline] n3_incr j i max m =
611 |   (* n3 XXX this is slow and we could be smarter about the search here.
612 |      Abstracting over dimension also makes us loose a bit of time. *)
613 |   let acc = ref 0 in
614 |   for k = 0 to 1 do (* Do the check in both dimensions. *)
615 |     let swap = k = 1 in
616 |     let i = if swap then j else i
617 |     and j = if swap then i else j in
618 |     let[@inline] get ~x ~y m =
619 |       if swap
620 |       then Matrix.get ~x:y ~y:x m
621 |       else Matrix.get ~x ~y m
622 |     in
623 |     if j + 6 <= max then begin
624 |       (* check for 1011101 at (j,i), (j,i) is already checked to be true) *)
625 |       if not (get ~x:(j + 1) ~y:i m) &&
626 |          get ~x:(j + 2) ~y:i m &&
627 |          get ~x:(j + 3) ~y:i m &&
628 |          get ~x:(j + 4) ~y:i m &&
629 |          not (get ~x:(j + 5) ~y:i m) &&
630 |          get ~x:(j + 6) ~y:i m
631 |       then begin
632 |         if j - 4 >= 0 then begin (* 0000 before *)
633 |           let count = ref 0 in
634 |           while (!count < 4 && not (get ~x:(j - !count - 1) ~y:i m))
635 |           do incr count done; if !count = 4 then acc := !acc + 40
636 |         end;
637 |         if j + 6 + 4 <= max then begin (* 0000 after *)
638 |           let count = ref 0 in
639 |           while (!count < 4 && not (get ~x:(j + 6 + !count + 1) ~y:i m))
640 |           do incr count done; if !count = 4 then acc := !acc + 40
641 |         end
642 |       end
643 |     end
644 |   done;
645 |   !acc
646 | 
647 | let matrix_penalty m = (* see table 11 *)
648 |   let max = Matrix.w m - 1 in
649 |   let n1 = ref 0 in
650 |   let n1_last_h = ref false and n1_acc_h = ref 0 in
651 |   let n1_last_v = ref false and n1_acc_v = ref 0 in
652 |   let n2 = ref 0 in
653 |   let n3 = ref 0 in
654 |   let n4_dark = ref 0 in
655 |   for i = 0 to max do
656 |     n1_last_h := Matrix.get ~x:0 ~y:i m; n1_acc_h := 0;
657 |     n1_last_v := Matrix.get ~x:i ~y:0 m; n1_acc_v := 0;
658 |     for j = 0 to max do
659 |       (* n1: consecutive colors horizontaly or vertically *)
660 |       let curr_h = Matrix.get ~x:j ~y:i m in
661 |       if !n1_last_h = curr_h then incr n1_acc_h else begin
662 |         if !n1_acc_h >= 5 then (n1 := !n1 + (!n1_acc_h - 2));
663 |         n1_last_h := curr_h; n1_acc_h := 1
664 |       end;
665 |       let curr_v = Matrix.get ~x:i ~y:j m in
666 |       if !n1_last_v = curr_v then incr n1_acc_v else begin
667 |         if !n1_acc_v >= 5 then (n1 := !n1 + (!n1_acc_v - 2));
668 |         n1_last_v := curr_v; n1_acc_v := 1
669 |       end;
670 |       (* n2: block of 2x2 of the same color *)
671 |       if j < max && i < max then begin
672 |         let v0 = curr_h in
673 |         let j' = j + 1 in
674 |         let v1 = Matrix.get ~x:j' ~y:i m in
675 |         if v1 <> v0 then () else
676 |         let i' = i + 1 in
677 |         let v2 = Matrix.get ~x:j ~y:i' m in
678 |         if v2 <> v1 then () else
679 |         let v3 = Matrix.get ~x:j' ~y:i' m in
680 |         if v3 <> v2 then () else (n2 := !n2 + 3)
681 |       end;
682 |       (* n3: find [0000]1011101[0000] *)
683 |       if curr_h then (n3 := !n3 + n3_incr j i max m);
684 |       (* n4: collect dark modules *)
685 |       if curr_h then incr n4_dark;
686 |     done;
687 |   done;
688 |   let n4 =
689 |     let r = (float !n4_dark) /. float (Matrix.w m * Matrix.w m) in
690 |     let dev = abs_float (50. -. r *. 100.) in
691 |     truncate (dev /. 5.) * 10
692 |   in
693 |   !n1 + !n2 + !n3 + n4
694 | 
695 | (* Matrix encoding *)
696 | 
697 | let layout_function_modules v m =
698 |   set_finder_patterns m;
699 |   set_timing_patterns m;
700 |   set_alignment_patterns v m;
701 |   set_version_information v m
702 | 
703 | let layout_data version ec_level mask data m =
704 |   set_format_information ec_level mask m;
705 |   set_data mask version data m;
706 |   ()
707 | 
708 | let base_matrix v =
709 |   let m = Matrix.zero ~w:(Prop.version_to_w v) in
710 |   layout_function_modules v m; m
711 | 
712 | let encode_matrix ?mask ~version:v ~ec_level ~mode s =
713 |   let data = encode_with_mode v ec_level mode s in
714 |   let data = encode_ec v ec_level data in
715 |   let base_matrix = base_matrix v in
716 |   let min_penalty = ref max_int in
717 |   let min_matrix = ref base_matrix in
718 |   let min_mask, max_mask = match mask with
719 |   | Some mask -> mask, mask (* only try this mask *)
720 |   | None -> 0, 7 (* all mask as per standard *)
721 |   in
722 |   for mask = min_mask to max_mask do
723 |     let m = Matrix.copy base_matrix in
724 |     layout_data v ec_level mask data m;
725 |     let p = matrix_penalty m in
726 |     if p < !min_penalty then (min_penalty := p; min_matrix := m)
727 |   done;
728 |   !min_matrix
729 | 
730 | (* Encoding *)
731 | 
732 | let find_mode ?mode _s = match mode with Some m -> m | None -> `Byte
733 | let rec get_best_level_for_version v ~mode ~after ~need =
734 |   (* Sometimes we can fit the same version with the next ec level *)
735 |   let try_next next = match need <= Prop.mode_capacity v next mode with
736 |   | true -> get_best_level_for_version v ~mode ~after:next ~need
737 |   | false -> after
738 |   in
739 |   match after with
740 |   | `L -> try_next `M | `M -> try_next `Q | `Q -> try_next `H | `H -> `H
741 | 
742 | let find_version ~version ~mode ~ec_level ~need = match version with
743 | | Some v ->
744 |     if need <= Prop.mode_capacity v ec_level mode
745 |     then Some (v, get_best_level_for_version v ~mode ~after:ec_level ~need)
746 |     else None
747 | | None ->
748 |     let rec loop (`V version as v) =
749 |       if version > Prop.version_max then None else
750 |       if need <= Prop.mode_capacity v ec_level mode
751 |       then Some (v, get_best_level_for_version v ~mode ~after:ec_level ~need)
752 |       else loop (`V (version + 1))
753 |     in
754 |     loop (`V Prop.version_min)
755 | 
756 | let encode ?mask ?version ?mode ?(ec_level = `M) s =
757 |   let mode = find_mode ?mode s in
758 |   match find_version ~version ~mode ~ec_level ~need:(String.length s) with
759 |   | None -> None
760 |   | Some (v, ec) -> Some (encode_matrix ?mask ~version:v ~ec_level:ec ~mode s)
761 | 


--------------------------------------------------------------------------------