├── .gitignore ├── .merlin ├── .ocp-indent ├── B0.ml ├── BRZO ├── CHANGES.md ├── DEVEL.md ├── LICENSE.md ├── README.md ├── TODO.md ├── _tags ├── doc ├── doc-aeo.png ├── doc-anz.png ├── doc-caps.png ├── doc-circle-outline.png ├── doc-dot.png ├── doc-earcs.png ├── doc-gray-circle.png ├── doc-gray-square.png ├── doc-joins.png ├── doc-scatter-plot.png ├── doc-subpaths.png ├── image_howto.mld ├── index.mld ├── semantics.mld └── tutorial.mld ├── opam ├── pkg ├── META └── pkg.ml ├── src ├── cairo │ ├── vg_cairo.mllib │ ├── vgr_cairo.ml │ └── vgr_cairo.mli ├── htmlc │ ├── vg_htmlc.mllib │ ├── vgr_htmlc.ml │ └── vgr_htmlc.mli ├── pdf │ ├── vg_pdf.mllib │ ├── vgr_pdf.ml │ └── vgr_pdf.mli ├── vg.ml ├── vg.mli ├── vg.mllib ├── vgr_svg.ml └── vgr_svg.mli └── test ├── attic_path.ml ├── db ├── alphas.ml ├── arrowhead.ml ├── colors.ml ├── db.ml ├── db.mli ├── db_contents.ml ├── doc.ml ├── escapes.ml ├── glyphs.ml ├── glyphs_pdf.ml ├── gradients.ml ├── graph.ml ├── illusions.ml ├── npcut.ml ├── open_sans.ml ├── open_sans.mli ├── paths.ml ├── rmark.ml └── uncut.ml ├── db_viewer.html ├── db_viewer.ml ├── examples.ml ├── font_glyphs.ml ├── min_cairo_mem.ml ├── min_cairo_png.ml ├── min_htmlc.html ├── min_htmlc.ml ├── min_pdf.ml ├── min_svg.ml ├── mui.ml ├── mui.mli ├── sqc.html ├── sqc.ml ├── test_vgr_cairo.ml ├── test_vgr_pdf.ml ├── test_vgr_stored.ml ├── test_vgr_svg.ml └── vecho.ml /.gitignore: -------------------------------------------------------------------------------- 1 | _b0 2 | _build 3 | tmp 4 | *.install -------------------------------------------------------------------------------- /.merlin: -------------------------------------------------------------------------------- 1 | PKG b0.kit otfm gg brr cairo2 2 | S src/** 3 | S test/** 4 | S db/** 5 | B _b0/** 6 | -------------------------------------------------------------------------------- /.ocp-indent: -------------------------------------------------------------------------------- 1 | strict_with=always,match_clause=4,strict_else=never -------------------------------------------------------------------------------- /B0.ml: -------------------------------------------------------------------------------- 1 | open B0_kit.V000 2 | 3 | (* OCaml library names *) 4 | 5 | let brr = B0_ocaml.libname "brr" 6 | let cairo = B0_ocaml.libname "cairo2" 7 | let gg = B0_ocaml.libname "gg" 8 | let otfm = B0_ocaml.libname "otfm" 9 | let unix = B0_ocaml.libname "unix" 10 | 11 | let vg = B0_ocaml.libname "vg" 12 | let vg_cairo = B0_ocaml.libname "vg.cairo" 13 | let vg_htmlc = B0_ocaml.libname "vg.htmlc" 14 | let vg_pdf = B0_ocaml.libname "vg.pdf" 15 | 16 | (* Libraries *) 17 | 18 | let vg_lib = 19 | let srcs = [`Dir ~/"src"] and requires = [gg] in 20 | B0_ocaml.lib vg ~srcs ~requires 21 | 22 | let vg_pdf_lib = 23 | let srcs = [`Dir ~/"src/pdf"] and requires = [gg; vg; otfm] in 24 | B0_ocaml.lib vg_pdf ~srcs ~requires 25 | 26 | let vg_htmlc_lib = 27 | let srcs = [`Dir ~/"src/htmlc"] and requires = [gg; vg; brr] in 28 | B0_ocaml.lib vg_htmlc ~srcs ~requires 29 | 30 | let vg_cairo_lib = 31 | let srcs = [`Dir ~/"src/cairo"] and requires = [gg; vg; cairo] in 32 | B0_ocaml.lib vg_cairo ~srcs ~requires 33 | 34 | let vg_svg_lib = 35 | let exports = [vg] in 36 | B0_ocaml.deprecated_lib ~exports (B0_ocaml.libname "vg.svg") 37 | 38 | (* Tests *) 39 | 40 | let test ?more_srcs:(srcs = []) ?(requires = []) ?doc base = 41 | let srcs = `File (Fpath.fmt "test/%s.ml" base) :: srcs in 42 | let requires = gg :: vg :: requires in 43 | B0_ocaml.exe base ?doc ~srcs ~requires 44 | 45 | let test_jsoo ?more_srcs:(srcs = []) ?(requires = []) ?doc base = 46 | let p = Fpath.fmt "test/%s" base in 47 | let srcs = `File Fpath.(p + ".ml") :: `File Fpath.(p + ".html") :: srcs in 48 | let requires = gg :: vg :: requires in 49 | B0_jsoo.html_page base ?doc ~srcs ~requires 50 | 51 | let test_min_svg = 52 | let doc = "Minimal SVG rendering example" in 53 | test "min_svg" ~doc 54 | 55 | let test_min_pdf = 56 | let doc = "Minimal PDF rendering example" in 57 | test "min_pdf" ~doc ~requires:[vg_pdf] 58 | 59 | let test_min_htmlc = 60 | let doc = "Minimal HTML canvas rendering example" in 61 | test_jsoo "min_htmlc" ~doc ~requires:[brr; vg_htmlc] 62 | 63 | let test_min_cairo = 64 | let doc = "Minimal cairo rendering to PNG example" in 65 | test "min_cairo_png" ~doc ~requires:[cairo; vg_cairo;] 66 | 67 | let test_min_cairo_mem = 68 | let doc = "Minimal cairo to memory rendering example" in 69 | test "min_cairo_mem" ~doc ~requires:[cairo; vg_cairo] 70 | 71 | let test_examples = 72 | test "examples" ~doc:"Examples for the docs" 73 | 74 | let test_font_glyphs = 75 | let doc = "Render a font's repertoire to PDF (without the glyph API)" in 76 | test "font_glyphs" ~requires:[otfm; vg_pdf] ~doc 77 | 78 | let test_sqc = 79 | let doc = "Square circle spiral illusion" in 80 | test_jsoo "sqc" ~requires:[brr; vg_htmlc] ~doc 81 | 82 | let test_vecho = 83 | let doc = "An echo(3) producing PDF banners" in 84 | test "vecho" ~doc ~requires:[otfm; vg_pdf] 85 | 86 | (* Vg test image database. *) 87 | 88 | let db_srcs = `Dir ~/"test/db" 89 | let sdb = [db_srcs; `File ~/"test/test_vgr_stored.ml"] 90 | 91 | let test_vgr_svg = 92 | let doc = "Renders test images with Vgr_svg" in 93 | test "test_vgr_svg" ~doc ~requires:[unix] ~more_srcs:sdb 94 | 95 | let test_vgr_cairo = 96 | let doc = "Renders test images with Vgr_cairo" in 97 | test "test_vgr_cairo" ~doc ~requires:[unix; vg_cairo] ~more_srcs:sdb 98 | 99 | let test_vgr_pdf = 100 | let doc = "Renders test images with Vgr_pdf" in 101 | test "test_vgr_pdf" ~doc ~requires:[unix; otfm; vg_pdf] ~more_srcs:sdb 102 | 103 | let db_viewer = 104 | let doc = "Test image browser viewer" in 105 | let more_srcs = [`File ~/"test/mui.ml"; `File ~/"test/mui.mli"; db_srcs ] in 106 | let requires = [otfm; brr; vg_pdf; vg_htmlc] in 107 | test_jsoo "db_viewer" ~doc ~requires ~more_srcs 108 | 109 | (* Packs *) 110 | 111 | let default = 112 | let meta = 113 | B0_meta.empty 114 | |> ~~ B0_meta.authors ["The vg programmers"] 115 | |> ~~ B0_meta.maintainers ["Daniel Bünzli "] 116 | |> ~~ B0_meta.homepage "https://erratique.ch/software/vg" 117 | |> ~~ B0_meta.online_doc "https://erratique.ch/software/vg/doc" 118 | |> ~~ B0_meta.licenses ["ISC"] 119 | |> ~~ B0_meta.repo "git+https://erratique.ch/repos/vg.git" 120 | |> ~~ B0_meta.issues "https://github.com/dbuenzli/vg/issues" 121 | |> ~~ B0_meta.description_tags 122 | ["pdf"; "svg"; "canvas"; "cairo"; "browser"; "declarative"; "graphics"; 123 | "org:erratique"; ] 124 | |> ~~ B0_opam.build 125 | {|[["ocaml" "pkg/pkg.ml" "build" "--dev-pkg" "%{dev}%" 126 | "--with-brr" "%{brr:installed}%" 127 | "--with-cairo2" "%{cairo2:installed}%" 128 | "--with-otfm" "%{otfm:installed}%"]]|} 129 | |> ~~ B0_opam.depopts 130 | [ "brr", ""; 131 | "cairo2", ""; 132 | "otfm", "";] 133 | |> ~~ B0_opam.conflicts 134 | [ "brr", {|< "0.0.6"|}; 135 | "cairo2", {|< "0.6"|}; 136 | "otfm", {|< "0.3.0"|} ] 137 | |> ~~ B0_opam.depends 138 | [ "ocaml", {|>= "4.14.0"|}; 139 | "ocamlfind", {|build|}; 140 | "ocamlbuild", {|build|}; 141 | "topkg", {|build & >= "1.0.3"|}; 142 | "gg", {|>= "1.0.0"|}; ] 143 | |> B0_meta.tag B0_opam.tag 144 | 145 | in 146 | B0_pack.make "default" ~doc:"vg package" ~meta ~locked:true @@ 147 | B0_unit.list () 148 | -------------------------------------------------------------------------------- /BRZO: -------------------------------------------------------------------------------- 1 | (srcs-x pkg tmp test db) -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | 2 | - `Vgr_svg` fix rendering of matrix transforms. 3 | Thanks to John Jackson for the report (#38). 4 | 5 | v0.9.5 2024-01-23 La Forclaz (VS) 6 | --------------------------------- 7 | 8 | - Add `Vg.P.smooth_{ccurve,qcurve}` to smoothly stitch cubic and 9 | quadratic Bézier curves. Thanks to François Thiré for the patch 10 | (#33). 11 | 12 | - `Vgr_htmlc` is now implemented via `brr` which becomes an optional 13 | dependency of the package. The package no longer depends on 14 | `js_of_ocaml` and `js_of_ocaml-ppx` at all. 15 | 16 | - `Vgr_htmlc.screen_resolution` is now a function taking unit. This 17 | allows the safe (but useless) linking of `Vgr_htmlc` in a web 18 | workers. 19 | 20 | - Fix `Vgr_pdf` glyph cut rendering. All glyphs id of the form 21 | `0xHH0D` were rendered as id `0xHH0A`. The text of the 2008 standard 22 | of the `Tj` operator (§9.4.3) misleads, PDF strings do perform 23 | newline normalisation (§7.3.4.2) so `0D` bytes also need to be 24 | escaped. 25 | 26 | - The `Vgr_svg` module is now part of the `vg` library. The `vg.svg` 27 | library is deprecated, it warns on usage and simply requires `vg`. 28 | 29 | - Reworked documentation into `.mld` pages. 30 | 31 | - Drop optional dependency on `uutf` and require OCaml 4.14.0. 32 | 33 | - Deprecate `Vg.{Font,I,P}.to_string`, they are not thread-safe. 34 | 35 | v0.9.4 2020-05-28 La Forclaz (VS) 36 | --------------------------------- 37 | 38 | - jsoo 3.6.0 support. 39 | 40 | v0.9.3 2019-06-14 Zagreb 41 | ------------------------ 42 | 43 | - Fix 4.08 `Pervasives`' deprecation. 44 | - jsoo 3.3.0 support. Thanks to @monstasat for the patch. 45 | 46 | v0.9.2 2018-11-02 Zagreb 47 | ------------------------ 48 | 49 | - Fix bug in `cairo2` backend. The initial clip region and clear 50 | was not done correctly. 51 | - Require `cairo2` 0.6. 52 | - Require OCaml 4.03. 53 | - Deprecate `Vg.(>>)`. Use OCaml's stdlib's `|>` operator instead. 54 | 55 | v0.9.1 2017-12-20 La Forclaz (VS) 56 | --------------------------------- 57 | 58 | - Fix a stackoverlow in the SVG renderer. Thanks to Guyslain Naves for 59 | the report. 60 | 61 | v0.9.0 2015-11-25 Zagreb 62 | ------------------------ 63 | 64 | - Automated migration from camlp4 to ppx. Many thanks to the authors 65 | of camlp4-to-ppx. 66 | - Use standard library `result` type. This changes the dubious interface 67 | of `Vgr_pdf.otf_font`. 68 | - Support uutf v1.0.0 and otfm v0.3.0. 69 | - Build depend on topkg. 70 | - Relicense from BSD3 to ISC. 71 | 72 | v0.8.2 2015-08-14 Cambridge (UK) 73 | -------------------------------- 74 | 75 | - Add `Vgr_cairo` module. A Cairo backend contributed by Arthur Wendling. 76 | - `-safe-string` support. In the public API this only affects users of 77 | stored `Manual` rendering destination: `Vg.Vgr.Manual.dst` now takes 78 | a `bytes` value instead of a `string`. 79 | 80 | 81 | v0.8.1 2014-08-23 Cambridge (UK) 82 | -------------------------------- 83 | 84 | - Use package builder topkg for distribution. 85 | - Fix build and installation glitches. Thanks to Philippe Veber and 86 | Grégoire Lionnet for the reports. 87 | - Gg 0.9.0 compatibility. 88 | - Add `Vgr_htmlc.screen_resolution` value. 89 | - `Vgr_htmlc.target` default value for `resolution` argument is now the 90 | screen resolution rather than 300ppi. 91 | - `Vgr_htmlc.target` add a `resize` optional argument. When set to 92 | `false` the canvas size is kept intact and doesn't resize according 93 | to renderable sizes. 94 | 95 | v0.8.0 2013-09-24 Lausanne 96 | -------------------------- 97 | 98 | First release. 99 | Sponsored by Citrix Systems R&D and OCaml Labs. 100 | -------------------------------------------------------------------------------- /DEVEL.md: -------------------------------------------------------------------------------- 1 | A few development tips. 2 | 3 | # Test image database 4 | 5 | The test image database in [`test/db`](test/db) is a collection of 6 | test images. 7 | 8 | Most images should render identically by with all renderers. However 9 | due to differences in renderer expressiveness and purposes this may 10 | not be possible or desirable. 11 | 12 | Each renderer has its own test executable, see `b0 list`. For example 13 | for `Vgr_pdf` you can issue: 14 | 15 | b0 -- test_vgr_pdf 16 | 17 | which renders all the test images to pdf in `/tmp`, invoke with `--help` 18 | for more options. 19 | 20 | Backends can be compared directly to each other by using the database 21 | viewer which runs in your browser: 22 | 23 | b0 -- .show-url db_viewer 24 | 25 | ## Adding a new test image 26 | 27 | To add a new image either add it to an existing relevant file or 28 | create a new file for it. In the latter case, include the new file in 29 | [`test/db/db_contents.ml`](test/db/db_contents.ml). 30 | 31 | An image is added by calling the function `Db.image` 32 | (see [`test/db/db.mli`](test/db/db.mli)) at the toplevel of the file: 33 | 34 | ```ocaml 35 | Db.image "a-unique-string-id" __POS__ 36 | ~author:("Author name", "scheme://uri/to/author") 37 | ~title:"Title for the image" 38 | ~tags:["a"; "list"; "of"; "relevant"; "tags";] 39 | ~note:"Note about the image and things to look for." 40 | ~size:(Size2.v 200 400) (* renderer surface size. *) 41 | ~view:(Box2.v P2.o (Size2.v 100 200)) (* image view rectangle. *) 42 | begin fun view -> (* view is the preceding view parameter. *) 43 | (* Define a value of type Vg.image here *) 44 | I.void 45 | end; 46 | ``` 47 | 48 | It's better if the thunked image value is self-contained, so that I 49 | can be copy-pasted to play around. 50 | 51 | 52 | 53 | 54 | 55 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | Copyright (c) 2013 The vg 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 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Vg — Declarative 2D vector graphics for OCaml 2 | ============================================= 3 | 4 | Vg is a declarative 2D vector graphics library. Images are values that 5 | denote functions mapping points of the cartesian plane to colors and 6 | combinators are provided to define and compose them. 7 | 8 | Renderers for PDF, SVG, Cairo and the HTML canvas are distributed with the 9 | module. An API allows to implement new renderers. 10 | 11 | Vg is distributed under the ISC license. Vg and the SVG renderer 12 | depend on [Gg]. The PDF renderer depends on [Otfm], the HTML canvas 13 | renderer depends on [Brr], the Cairo renderer depends on [cairo2]. 14 | 15 | [Gg]: http://erratique.ch/software/gg 16 | [Otfm]: http://erratique.ch/software/otfm 17 | [Brr]: http://erratique.ch/software/brr 18 | [cairo2]: https://github.com/Chris00/ocaml-cairo 19 | 20 | Home page: http://erratique.ch/software/vg 21 | 22 | ## Installation 23 | 24 | Vg can be installed with `opam`: 25 | 26 | opam install vg # SVG renderer only 27 | opam install brr cairo2 otfm vg # All renderers 28 | 29 | If you don't use `opam` consult the [`opam`](opam) file for 30 | build instructions and a complete specification of the dependencies. 31 | 32 | ## Documentation 33 | 34 | The documentation can be consulted [online] or via `odig doc vg`. 35 | 36 | Questions are welcome but better asked on the [OCaml forum] than on 37 | the issue tracker. 38 | 39 | [online]: http://erratique.ch/software/vg/doc/ 40 | [OCaml forum]: https://discuss.ocaml.org/ 41 | 42 | ## Sample programs 43 | 44 | A database of test images can be found in the [`test/db`](test/db) 45 | directory. An online rendering of the database with the different 46 | backends and links to the source of images is available 47 | [here][online-db] 48 | 49 | A few test programs and minimal rendering examples can be found in the 50 | [`test`](test) directory, see `b0 list`. 51 | 52 | [online-db]: http://erratique.ch/software/vg/demos/db_viewer.html 53 | -------------------------------------------------------------------------------- /TODO.md: -------------------------------------------------------------------------------- 1 | # Current backend improvements 2 | 3 | * git grep FIXME 4 | * SVG renderer, try to handle more glyph cuts. 5 | * SVG renderer, give the opportunity to use SVG glyphs ? If no font 6 | resolver is provided, do it like now otherwise embed glyphs. 7 | * Canvas, try to handle more glyph cuts, transform mess. 8 | * PDF, implement stream compression. LZW would be easiest, deflate 9 | would be nice. 10 | * PDF, implement gradients with alpha, have a look at how Inkscape 11 | encodes them. 12 | * PDF, implement font subsetting. 13 | * PDF, text extraction, consider also using /ToUnicode maps instead of 14 | solely /ActualText. 15 | http://lists.cairographics.org/archives/cairo/2007-September/011427.html 16 | 17 | # Raster image primitive 18 | 19 | val Image.raster : Gg.box2 -> Gg.raster -> image 20 | 21 | * Accept directly a Gg.raster or create a proxy resolved by backends 22 | like for fonts ? Problem is source is quite different e.g. 23 | in html canvas. Gg's raster formats can be plentiful, normalize or 24 | mandate a few formats ? 25 | * Q: will js_of_ocaml support bigarrays over typed arrays once ? 26 | * Potentially add this comment under Remarks and tips 27 | {- Images are said to be immutable. This is only true if you 28 | don't change the samples of raster images given to {!I.raster}.} 29 | 30 | # Path convenience 31 | 32 | Quite a few convience operations on paths could be added. This would 33 | be only at the Vg level, renderers wouldn't need to be extended. But 34 | does it really belong in Vg ? Tension between general computational 35 | geometry lib and rendering lib. However quite a few of these things 36 | could be used by a potential rasterizer. 37 | 38 | * P.mem : area -> path -> p2 -> bool 39 | * P.length : path -> float (* arc length *) 40 | * P.split : path -> float -> path * path (* split at given distance on path *) 41 | * P.cubic_fold 42 | * P.square 43 | * Boolean operations on paths 44 | * Minkowski sum 45 | * The folds that are [`test/attic_path.ml`](test/attic_path) 46 | 47 | I'm more and more convinced that this doesn't belong in Vg though, the 48 | folds in `attic_path.ml` also show that this can be provided as 49 | an external component with minimal reliance on `Vg.Vgr.Private`. 50 | 51 | # Blending groups and operators 52 | 53 | Support more blending operators, but is it really that used in 54 | practice ? Support group opacity, that would be really useful, however 55 | HTML canvas doesn't support it. 56 | 57 | From an API point of view it's just a matter of adding the following 58 | two optional parameters to I.blend: 59 | 60 | I.blend : ?a:float -> ?blender:blender -> image -> image -> image 61 | 62 | * http://cairographics.org/operators/ 63 | * http://lists.cairographics.org/archives/cairo/2008-October/015362.html 64 | * http://www.w3.org/TR/compositing/ 65 | 66 | # Software rasterizer and OpenGL backend 67 | 68 | * http://processingjs.nihongoresources.com/bezierinfo/ 69 | * http://www.codeproject.com/Articles/226569/Drawing-polylines-by-tessellation 70 | * http://portal.acm.org/citation.cfm?id=129906 71 | * http://books.google.com/books?q=vatti+clipping+agoston 72 | * http://www.antigrain.com/research/adaptive_bezier/index.html 73 | 74 | # Db images ideas 75 | 76 | * Test miànjï 面积 (area, surface area), vector. 77 | * Test font http://www.twardoch.com/fonts/ Nadeyezhda 78 | * Quadratic paths. 79 | * Test degenerate color stops discarding. 80 | * Test degenerate subpaths rendering. 81 | * Dash offset is for start of each subpath, negative. 82 | * Primitives, special cases axial with p = p', radial with c = c'. 83 | * Test geometric primitives, quadric and ellipse for pdf renderer. 84 | * The IEEE 754 double floating point line vs the real line. 85 | * The IEEE 754 double floating point grid vs the real plane 86 | * How many doubles between 10 and 11, 100 and 101, 1000 and 1001, etc. 87 | or 2 ** n and 2 ** n+1. 88 | * Rectangle, area cut of w = 0 or s = 0 is nothing but outline cut 89 | is segment. 90 | -------------------------------------------------------------------------------- /_tags: -------------------------------------------------------------------------------- 1 | true : bin_annot, safe_string 2 | true : package(gg) 3 | <_b0> : -traverse 4 | 5 | : include 6 | : include 7 | : include 8 | : include 9 | 10 | : package(otfm) 11 | : package(brr) 12 | : package(cairo2) 13 | 14 | : package(otfm) -------------------------------------------------------------------------------- /doc/doc-aeo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dbuenzli/vg/252c92f4388dc8814a95b0816180454a411d7b91/doc/doc-aeo.png -------------------------------------------------------------------------------- /doc/doc-anz.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dbuenzli/vg/252c92f4388dc8814a95b0816180454a411d7b91/doc/doc-anz.png -------------------------------------------------------------------------------- /doc/doc-caps.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dbuenzli/vg/252c92f4388dc8814a95b0816180454a411d7b91/doc/doc-caps.png -------------------------------------------------------------------------------- /doc/doc-circle-outline.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dbuenzli/vg/252c92f4388dc8814a95b0816180454a411d7b91/doc/doc-circle-outline.png -------------------------------------------------------------------------------- /doc/doc-dot.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dbuenzli/vg/252c92f4388dc8814a95b0816180454a411d7b91/doc/doc-dot.png -------------------------------------------------------------------------------- /doc/doc-earcs.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dbuenzli/vg/252c92f4388dc8814a95b0816180454a411d7b91/doc/doc-earcs.png -------------------------------------------------------------------------------- /doc/doc-gray-circle.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dbuenzli/vg/252c92f4388dc8814a95b0816180454a411d7b91/doc/doc-gray-circle.png -------------------------------------------------------------------------------- /doc/doc-gray-square.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dbuenzli/vg/252c92f4388dc8814a95b0816180454a411d7b91/doc/doc-gray-square.png -------------------------------------------------------------------------------- /doc/doc-joins.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dbuenzli/vg/252c92f4388dc8814a95b0816180454a411d7b91/doc/doc-joins.png -------------------------------------------------------------------------------- /doc/doc-scatter-plot.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dbuenzli/vg/252c92f4388dc8814a95b0816180454a411d7b91/doc/doc-scatter-plot.png -------------------------------------------------------------------------------- /doc/doc-subpaths.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dbuenzli/vg/252c92f4388dc8814a95b0816180454a411d7b91/doc/doc-subpaths.png -------------------------------------------------------------------------------- /doc/image_howto.mld: -------------------------------------------------------------------------------- 1 | {0 Image howto} 2 | 3 | The following examples show for each renderer the minimal code and 4 | compilation instructions needed to output an image. 5 | 6 | Other examples of images and their source can be found in the 7 | {{:http://erratique.ch/software/vg/demos/db_viewer.html}online version} 8 | of Vg's test image database. Clicking on the title of an image brings 9 | you to its definition. 10 | 11 | {1:minpdf Minimal PDF output} 12 | 13 | This example produces a one-page PDF document. Step by step 14 | we have: 15 | 16 | {ol 17 | {- We define an image.} 18 | {- We define a function to render the image with the {!Vgr_pdf} renderer 19 | on a given output channel. This function defines some metadata for the 20 | image, a function to print rendering warnings and then renders the image.} 21 | {- We define an entry point for the program in which we put [stdout] in 22 | binary mode to avoid any unhelpful surprises and render the image on it.}} 23 | 24 | {[ 25 | cat << 'EOF' > min_pdf.ml 26 | open Gg 27 | open Vg 28 | 29 | (* 1. Define your image *) 30 | 31 | let aspect = 1.618 32 | let size = Size2.v (aspect *. 100.) 100. (* mm *) 33 | let view = Box2.v P2.o (Size2.v aspect 1.) 34 | let image = I.const (Color.v_srgb 0.314 0.784 0.471) 35 | 36 | (* 2. Render *) 37 | 38 | let render oc = 39 | let title = "Vgr_pdf minimal example" in 40 | let description = "Emerald Color" in 41 | let xmp = Vgr.xmp ~title ~description () in 42 | let warn w = Vgr.pp_warning Format.err_formatter w in 43 | let r = Vgr.create ~warn (Vgr_pdf.target ~xmp ()) (`Channel oc) in 44 | ignore (Vgr.render r (`Image (size, view, image))); 45 | ignore (Vgr.render r `End) 46 | 47 | (* 3. Main *) 48 | 49 | let main () = Out_channel.set_binary_mode stdout true; render stdout; 0 50 | let () = if !Sys.interactive then () else exit (main ()) 51 | EOF 52 | ]} 53 | The source can be compiled an executed with: 54 | {v 55 | ocamlfind ocamlopt -package gg,vg,vg.pdf -linkpkg min_pdf.ml 56 | ./a.out > min.pdf 57 | v} 58 | 59 | {1:minsvg Minimal SVG output} 60 | 61 | This example produces an SVG image. Step by step we have: 62 | 63 | {ol 64 | {- We define an image.} 65 | {- We define a function to render the image with the {!Vgr_svg} renderer 66 | on a given output channel. This function defines some metadata for the 67 | image, a function to print rendering warnings and then renders the image.} 68 | {- We define an entry point for the program in which we put [stdout] in 69 | binary mode to avoid any unhelpful surprises and render the image on it.}} 70 | 71 | {[ 72 | cat << 'EOF' > min_svg.ml 73 | open Gg 74 | open Vg 75 | 76 | (* 1. Define your image *) 77 | 78 | let aspect = 1.618 79 | let size = Size2.v (aspect *. 100.) 100. (* mm *) 80 | let view = Box2.v P2.o (Size2.v aspect 1.) 81 | let image = I.const (Color.v_srgb 0.314 0.784 0.471) 82 | 83 | (* 2. Render *) 84 | 85 | let render oc = 86 | let title = "Vgr_svg minimal example" in 87 | let description = "Emerald Color" in 88 | let xmp = Vgr.xmp ~title ~description () in 89 | let warn w = Vgr.pp_warning Format.err_formatter w in 90 | let r = Vgr.create ~warn (Vgr_svg.target ~xmp ()) (`Channel oc) in 91 | ignore (Vgr.render r (`Image (size, view, image))); 92 | ignore (Vgr.render r `End) 93 | 94 | (* 3. Main *) 95 | 96 | let main () = Out_channel.set_binary_mode stdout true; render stdout; 0 97 | let () = if !Sys.interactive then () else exit (main ()) 98 | EOF 99 | ]} 100 | The source can be compiled and executed with: 101 | {v 102 | ocamlfind ocamlopt -package gg,vg,vg.svg -linkpkg min_svg.ml 103 | ./a.out > min.svg 104 | v} 105 | 106 | {1:minhtmlc Minimal HTML canvas output} 107 | 108 | This example produces a web page with an HTML canvas image. It uses 109 | the {!Brr} library to interact with the browser. Step by step we have: 110 | 111 | {ol 112 | {- Define an image.} 113 | {- Create a canvas element [cnv].} 114 | {- Create and add to the DOM an anchor [anchor] that parents [cnv]. 115 | This allows to download a (usually PNG) file of the image by clicking 116 | on it.} 117 | {- Create a renderer [r] targeting the canvas [cnv].} 118 | {- Render the image.} 119 | {- Ask the canvas for an image data URL and set it as the the link of the 120 | anchor.} 121 | {- Invoke the image render when the page loads.}} 122 | 123 | {[ 124 | cat << 'EOF' > min_htmlc.ml 125 | open Gg 126 | open Vg 127 | open Brr 128 | open Brr_canvas 129 | 130 | (* 1. Define your image *) 131 | 132 | let aspect = 1.618 133 | let size = Size2.v (aspect *. 100.) 100. (* mm *) 134 | let view = Box2.v P2.o (Size2.v aspect 1.) 135 | let image = I.const (Color.v_srgb 0.314 0.784 0.471) 136 | 137 | (* Browser bureaucracy. *) 138 | 139 | let main () = 140 | let cnv = Brr_canvas.Canvas.create [] (* 2 *) in 141 | let anchor = (* 3 *) 142 | let href = At.href (Jstr.v "#") in 143 | let title = At.title (Jstr.v "Download PNG file") in 144 | let download = At.v (Jstr.v "download") (Jstr.v "min_htmlc.png") in 145 | let a = El.a ~at:[href; title; download] [Brr_canvas.Canvas.to_el cnv] in 146 | El.append_children (Document.body G.document) [a]; a 147 | in 148 | let r = Vgr.create (Vgr_htmlc.target cnv) `Other in (* 4 *) 149 | ignore (Vgr.render r (`Image (size, view, image))); (* 5 *) 150 | ignore (Vgr.render r `End); 151 | let data = (* 6 *) 152 | Canvas.to_data_url cnv |> Console.log_if_error ~use:Jstr.empty 153 | in 154 | El.set_at At.Name.href (Some data) anchor 155 | 156 | let () = main () (* 7 *) 157 | EOF 158 | ]} 159 | The source needs to be compiled to bytecode and then to JavaScript 160 | with [js_of_ocaml]: 161 | {v 162 | ocamlfind ocamlc -package brr,gg,vg,vg.htmlc -linkpkg min_htmlc.ml 163 | js_of_ocaml -o min_htmlc.js a.out 164 | v} 165 | 166 | Finally we need to link that with a minimal HTML file. The following one 167 | will do: 168 | {v 169 | cat << 'EOF' > min_htmlc.html 170 | 171 | 172 | 173 | 174 | 175 | 176 | 179 | Vgr_htmlc minimal example 180 | 181 | 182 | 183 | 184 | 185 | EOF 186 | v} 187 | You can now enjoy your image by invoking: 188 | {v 189 | xdg-open min_htmlc.html # Linux and XDG compliant systems 190 | open min_htmlc.html # macOS 191 | start min_htmlc.html # Windows 192 | v} 193 | 194 | {1:mincairopng Minimal Cairo PNG output} 195 | 196 | This example produces a PNG image with Cairo. Step by step 197 | we have: 198 | 199 | {ol 200 | {- We define an image.} 201 | {- We define a function to render the image with the {!Vgr_cairo} renderer 202 | on a given output channel. This function defines the output format, 203 | a function to print rendering warnings and then renders the image.} 204 | {- We define an entry point for the program in which we put [stdout] in 205 | binary mode to avoid any unhelpful surprises and render the image on it.}} 206 | 207 | {[ 208 | cat << 'EOF' > min_cairo_png.ml 209 | open Gg 210 | open Vg 211 | 212 | (* 1. Define your image *) 213 | 214 | let aspect = 1.618 215 | let size = Size2.v (aspect *. 100.) 100. (* mm *) 216 | let view = Box2.v P2.o (Size2.v aspect 1.) 217 | let image = I.const (Color.v_srgb 0.314 0.784 0.471) 218 | 219 | (* 2. Render *) 220 | 221 | let render oc = 222 | let res = 300. /. 0.0254 (* 300dpi in dots per meters *) in 223 | let format = `Png (Size2.v res res) in 224 | let warn w = Vgr.pp_warning Format.err_formatter w in 225 | let r = Vgr.create ~warn (Vgr_cairo.stored_target format) (`Channel oc) in 226 | ignore (Vgr.render r (`Image (size, view, image))); 227 | ignore (Vgr.render r `End) 228 | 229 | (* 3. Main *) 230 | 231 | let main () = Out_channel.set_binary_mode stdout true; render stdout; 0 232 | let () = if !Sys.interactive then () else exit (main ()) 233 | EOF 234 | ]} 235 | 236 | The source can be compiled an executed with: 237 | {v 238 | ocamlfind ocamlopt -package gg,vg,vg.cairo -linkpkg min_cairo_png.ml 239 | ./a.out > min.png 240 | v} 241 | 242 | {1:mincairomem Minimal Cairo memory buffer rendering} 243 | 244 | This example produces a raster image in memory with Cairo. Step by step 245 | we have: 246 | 247 | {ol 248 | {- We define an image.} 249 | {- We render the image to a bigarray of bytes}} 250 | 251 | {[ 252 | cat << 'EOF' > min_cairo_mem.ml 253 | open Gg 254 | open Vg 255 | 256 | (* 1. Define your image *) 257 | 258 | let aspect = 1.618 259 | let size = Size2.v (aspect *. 100.) 100. (* mm *) 260 | let view = Box2.v P2.o (Size2.v aspect 1.) 261 | let image = I.const (Color.v_srgb 0.314 0.784 0.471) 262 | 263 | (* 2. Render *) 264 | 265 | let raster, stride = 266 | let res = 300. /. 25.4 (* 300dpi in dots per mm *) in 267 | let w = int_of_float (res *. Size2.w size) in 268 | let h = int_of_float (res *. Size2.h size) in 269 | let stride = Cairo.Image.(stride_for_width ARGB32 w) in 270 | let data = Bigarray.(Array1.create int8_unsigned c_layout (stride * h)) in 271 | let surface = Cairo.Image.(create_for_data8 data ARGB32 ~stride ~w ~h) in 272 | let ctx = Cairo.create surface in 273 | Cairo.scale ctx res res; 274 | let warn w = Vgr.pp_warning Format.err_formatter w in 275 | let r = Vgr.create ~warn (Vgr_cairo.target ctx) `Other in 276 | ignore (Vgr.render r (`Image (size, view, image))); 277 | ignore (Vgr.render r `End); 278 | Cairo.Surface.flush surface; 279 | Cairo.Surface.finish surface; 280 | data, stride 281 | EOF 282 | ]} 283 | 284 | This example can be compiled with: 285 | {v 286 | ocamlfind ocamlopt -package cairo2,gg,vg,vg.cairo -linkpkg min_cairo_mem.ml 287 | v} 288 | -------------------------------------------------------------------------------- /doc/index.mld: -------------------------------------------------------------------------------- 1 | {0 Vg {%html: %%VERSION%%%}} 2 | 3 | Vg is a declarative 2D vector graphics library. Images are 4 | {{!Vg.image}values} that denote functions mapping points of the 5 | cartesian plane to colors and {{!Vg.I}combinators} are provided to 6 | define and compose them. 7 | 8 | Renderers for {{!Vgr_pdf}PDF}, {{!Vgr_svg}SVG}, the HTML 9 | {{!Vgr_htmlc}canvas} and {{!Vgr_cairo}Cairo} are distributed with the 10 | library. An {{!Vg.Vgr.Private}API} allows to implement new renderers. 11 | 12 | {1:manuals Manuals} 13 | 14 | These manuals are available: 15 | 16 | - The {{!page-tutorial}tutorial} is a conceptual 17 | overview of the library. It is recommended reading. 18 | - The {{!page-semantics}semantics} has the notations and definitions 19 | which give precise meaning to images and their combinators. 20 | - The {{!page-image_howto}image howto} has minimal setup examples to render 21 | images. 22 | 23 | {1:library_vg Library [vg]} 24 | 25 | {!modules: Vg Vgr_svg} 26 | 27 | {1:library_renderer Libraries [vg.{cairo,htmlc,pdf}] } 28 | 29 | Each of these modules is in its own library as they entails more 30 | dependencies. 31 | 32 | {!modules: Vgr_cairo Vgr_htmlc Vgr_pdf} 33 | -------------------------------------------------------------------------------- /doc/semantics.mld: -------------------------------------------------------------------------------- 1 | {0 The semantics of Vg} 2 | 3 | The following notations and definitions give precise meaning to images 4 | and their combinators. 5 | 6 | {1:semcolors Colors} 7 | 8 | The semantics of colors is the one ascribed to 9 | {{!Gg.Color.t}[Gg.color]}: colors are in a {e linearized} sRGBA space. 10 | 11 | {2:semstops Color stops} 12 | 13 | A value of type {!Gg.Color.type-stops} specifies a color at each point 14 | of the 1D {e unit} space. It is defined by a list of pairs 15 | [(t]{_i}[, c]{_i}[)] where [t]{_i} is a value from [0] to [1] and 16 | [c]{_i} the corresponding color at that value. Colors at points 17 | between [t]{_i} and [t]{_i+1} are linearly interpolated between 18 | [c]{_i} and [c]{_i+1}. If [t]{_i} lies outside [0] to [1] 19 | or if [t]{_i-1} >= [t]{_i} the semantics is undefined. 20 | 21 | Given a stops value [stops = \[][(t]{_0}[, c]{_0}[);] 22 | [(t]{_1}[,c]{_1}[);] ... [(t]{_n}[, c]{_n}[)][\]] and any point 23 | [t] of 1D space, the semantic function: 24 | 25 | \[\] [: Gg.Color.stops -> float -> Gg.color] 26 | 27 | maps them to a color value written \[[stops]\]{_t} as follows. 28 | 29 | {ul 30 | {- \[[stops]\]{_t} = [(0, 0, 0, 0)] for any [t] if [stops = []]} 31 | {- \[[stops]\]{_t} [= c]{_0} if [t < t]{_0}.} 32 | {- \[[stops]\]{_t} [= c]{_n} if [t >= t]{_n}.} 33 | {- \[[stops]\]{_t} [= (1-u)c]{_i}[ + uc]{_i+1} 34 | with [u = (t - t]{_i}[)/(t]{_i+1}[-t]{_i}[)] 35 | if [t]{_i} [<= t <] [t]{_i+1}}} 36 | 37 | {1:semimages Images} 38 | 39 | Values of type {!Vg.image} represent maps from the infinite 2D euclidian 40 | space to {{!semcolors}colors}. Given an image [i] and a point [pt] of 41 | the plane the semantic function 42 | 43 | \[\][: image -> Gg.p2 -> Gg.color] 44 | 45 | maps them to a color value written \[[i]\]{_[pt]} representing the 46 | image's color at this point. 47 | 48 | {1:sempaths Paths and areas} 49 | 50 | A value of type {!Vg.path} is a list of subpaths. A subpath is a list of 51 | {e directed} and connected curved {e segments}. Subpaths are 52 | disconnected from each other and may (self-)intersect. 53 | 54 | A path and an area specification of type {!Vg.P.area} define a finite 55 | area of the 2D euclidian space. Given an area specification [a], a 56 | path [p] and a point [pt], the semantic function: 57 | 58 | \[\]: [P.area -> path -> Gg.p2 -> bool] 59 | 60 | maps them to a boolean value written \[[a], [p]\]{_[pt]} that 61 | indicates whether [pt] belongs to the area or not. 62 | 63 | The semantics of area rules is as follows: 64 | 65 | {ul 66 | {- \[[`Anz], [p]\]{_[pt]} is [true] iff the winding number of [p] 67 | around [pt] is non zero. To determine the winding number cast 68 | a ray from [pt] to infinity in any direction (just make sure 69 | the ray doesn't intersect [p] tangently or at a 70 | singularity). Starting with zero add one for each intersection 71 | with a counter-clockwise oriented segment of [p] and substract 72 | one for each clockwise ones. The resulting sum is the 73 | winding number. This is usually refered to as the {e non-zero winding 74 | rule} and is the default for {!Vg.I.val-cut}. 75 | {%html: %}} 76 | {- \[[`Aeo], [p]\]{_[pt]} is [true] iff the number of 77 | intersections of [p] with a ray cast from [pt] to infinity in 78 | any direction is odd (just make sure the ray doesn't intersect 79 | [p] tangently or at a singularity). This is usually refered 80 | to as the {e even-odd rule}. 81 | {%html: %}} 82 | {- \[[`O o], [p]\]{_[pt]} is [true] iff [pt] is in the outline 83 | area of [p] as defined by the value [o] of type {!Vg.P.type-outline}. 84 | See {!semoutlines}, {!semjoins}, {!semcaps}, {!semdashes}.}} 85 | 86 | {2:semoutlines Outline areas} 87 | 88 | The outline area of a path specified by a value [o] of type 89 | {!Vg.P.type-outline} is the union of its subpaths outline areas. 90 | 91 | A subpath outline area is inside the parallel curves at a distance 92 | [o.width / 2] of its path segments that are joined accoring to the 93 | join style [o.join] (see below) and closed at the subpath end points 94 | with a cap style [o.cap] (see below). The outline area of a subpath 95 | can also be chopped at regular intervals according to the [o.dashes] 96 | parameter (see below). 97 | 98 | {3:semjoins Segment jointures} 99 | 100 | The shape of subpath segment jointures is specified in 101 | [o.join] by a value of type {!Vg.P.type-join}. From left to right: 102 | {%html: %} 104 | {ul 105 | {- [`Miter], the outer parallel curves are extended until they 106 | meet unless the joining angle is smaller than 107 | [o.miter_angle] in which case the join is converted to a 108 | bevel.} 109 | {- [`Round], joins the outer parallel curves by a semicircle 110 | centered at the end point with a diameter equal to [o.width].} 111 | {- [`Bevel], joins the outer parallel curves by a segment.}} 112 | 113 | {3:semcaps Subpath caps} 114 | 115 | The shape of subpath (or dashes) end points is specified in 116 | [o.cap] by a value of type {!Vg.P.type-cap}. From left to right: 117 | {%html: %} 118 | {ul 119 | {- [`Butt], end points are square and extend only to the exact end point of 120 | the path.} 121 | {- [`Round], end points are rounded by a semicircle at the end point with a 122 | diameter equal to [o.width].} 123 | {- [`Square], end points are square and extend by a distance 124 | equal to half [o.width].}} 125 | 126 | {3:semdashes Outline dashes} 127 | 128 | The path outline area can be chopped at regular intervals by 129 | specifying a value [(off, pat)] of type {!Vg.P.type-dashes} in 130 | [o.dashes]. 131 | 132 | The {e dash pattern} [pat] is a list of lengths that specify the 133 | length of alternating dashes and gaps (starting with dashes). The {e 134 | dash offset} [off] is a {e positive} offset that indicates where to 135 | start in the dash pattern at the beginning of a subpath. 136 | -------------------------------------------------------------------------------- /doc/tutorial.mld: -------------------------------------------------------------------------------- 1 | {0 The Vg tutorial} 2 | 3 | Vg is designed to be opened in your module. This defines only types 4 | and modules in your scope. Thus to use Vg start with : 5 | 6 | {[ 7 | open Gg 8 | open Vg 9 | ]} 10 | 11 | {!Gg} gives us types for points ({!Gg.p2}), vectors ({!Gg.v2}), 2D 12 | extents ({!Gg.size2}), rectangles ({!Gg.box2}) and colors 13 | ({!Gg.color}). 14 | 15 | Later you may want to read {!Gg}'s documentation {{!Gg.basics}basics} 16 | but for now it is sufficient to know that each of these types has a 17 | literal constructor named [v] in a module named after the capitalized 18 | type name – {{!Gg.P2.v}[P2.v]}, {{!Gg.V2.v}[V2.v]}, etc. 19 | 20 | {1:collage A collage model} 21 | 22 | Usual vector graphics libraries follow a {e painter model} in which 23 | paths are filled, stroked and blended on top of each other to produce 24 | a final image. Vg departs from that, it has a {e collage model} in 25 | which paths define 2D areas in infinite images that are {e cut} to 26 | define new infinite images to be blended on top of each other. 27 | 28 | The collage model maps very well to a declarative imaging model. It 29 | is also very clear from a specification point of view, both 30 | mathematically and metaphorically. This cannot be said from the 31 | painter model where the semantics of an operation like stroking a 32 | self-intersecting translucent path —  which usually applies the paint 33 | only once —  doesn't directly map to the underlying paint stroke 34 | metaphor. The collage model is also more economical from a conceptual 35 | point view since image cuts and blends naturally unify the distinct 36 | concepts of clipping paths, path strokes, path fills and compositing 37 | groups (unsupported for now in Vg) of the painter model. 38 | 39 | The collage model introduced in the following sections was stolen 40 | and adapted from the following works. 41 | 42 | {ul 43 | {- Conal Elliott. 44 | {e {{:http://conal.net/papers/bridges2001/}Functional Image Synthesis}}, 45 | Proceedings of Bridges, 2001.} 46 | {- Antony Courtney. {e Haven : Functional Vector Graphics}, chapter 6 in 47 | {{:http://web.archive.org/web/20060207195702/http://www.apocalypse.org/pub/u/antony/work/pubs/ac-thesis.pdf}Modeling User Interfaces in a Functional 48 | Language}, Ph.D. Thesis, Yale University, 2004.}} 49 | 50 | {1:infinite Infinite images} 51 | 52 | Images are immutable and abstract value of type {!image}. {e 53 | Conceptually}, images are seen as functions mapping points of the 54 | infinite 2D plane to colors: 55 | 56 | [type Vg.image ] ≈  [Gg.p2 -> Gg.color] 57 | 58 | The simplest image is a constant image: an image that associates the 59 | same color to every point in the plane. For a constant gray of 60 | intensity 0.5 this would be expressed by the function: 61 | 62 | {[ 63 | fun _ -> Color.gray 0.5 64 | ]} 65 | 66 | In Vg the combinator {!Vg.I.const} produces constant infinite images, 67 | the above function is written: 68 | 69 | {[ 70 | let gray = I.const (Color.gray 0.5) 71 | ]} 72 | 73 | The module {!Vg.I} contains all the combinators to define and compose 74 | infinite images. We will explore some of them later. But for now let's 75 | just render that fascinating image. 76 | 77 | {1:rendering Rendering} 78 | 79 | An infinite image alone cannot be rendered. We need a {e finite} view 80 | rectangle and a specification of that view's physical size on the 81 | render target. These informations are coupled together with an image 82 | to form a {!Vg.Vgr.type-renderable}. 83 | 84 | Renderables can be given to a renderer for display via the function 85 | {!Vg.Vgr.val-render}. Renderers are created with {!Vg.Vgr.create} and need 86 | a {{!Vg.Vgr.target}render target} value that defines the concrete 87 | renderer implementation used (PDF, SVG, HTML canvas etc.). 88 | 89 | The following function outputs the unit square of [gray] on a 30x30 90 | millimeters SVG target in the file [/tmp/vg-tutorial.svg]: 91 | 92 | {[ 93 | let svg_of_unit_square i = 94 | try 95 | Out_channel.with_open_bin "/tmp/vg-tutorial.svg" @@ fun oc -> 96 | let size = Size2.v 30. 30. (* mm *) in 97 | let view = Box2.unit in 98 | let r = Vgr.create (Vgr_svg.target ()) (`Channel oc) in 99 | ignore (Vgr.render r (`Image (size, view, i))); 100 | ignore (Vgr.render r `End); 101 | with Sys_error e -> prerr_endline e 102 | 103 | let () = svg_of_unit_square gray 104 | ]} 105 | 106 | The result should be an SVG image with a gray square 107 | like this: 108 | 109 | {%html: %} 111 | 112 | {1:coordinates Coordinate space} 113 | 114 | [Vg]'s cartesian coordinate space has its origin at the bottom left 115 | with the x-axis pointing right, the y-axis pointing up. 116 | 117 | It has no units, you define what they mean to you. However a 118 | {{!Vg.Vgr.type-renderable}renderable} implicitely defines a physical unit 119 | for [Vg]'s coordinate space: the corners of the specified view 120 | rectangle are mapped on a rectangular area of the given physical size 121 | on the target. 122 | 123 | {1:scissors Scissors and glue} 124 | 125 | Constant images can be boring. To make things more interesting 126 | [Vg] gives you scissors: the {!Vg.I.val-cut} combinator. 127 | 128 | This combinator takes a finite area of the plane defined by a path 129 | [path] (more on paths later) and a source image [img] to define the 130 | image [I.cut path img] that has the color of the source image in the 131 | area defined by the path and the invisible transparent black color 132 | ({!Gg.Color.void}) everywhere else. In other words [I.cut path img] 133 | represents this function: 134 | 135 | {[ 136 | fun pt -> if inside path pt then img pt else Color.void 137 | ]} 138 | 139 | The following code cuts a circle of radius [0.4] centered in the unit 140 | square in the [gray] image defined before. 141 | 142 | {[ 143 | let circle = P.empty |> P.circle (P2.v 0.5 0.5) 0.4 144 | let gray_circle = I.cut circle gray 145 | ]} 146 | 147 | Rendered by [svg_of_unit_square] the result is: 148 | 149 | {%html: %} 151 | 152 | Note that the background color surrounding the circle does not belong 153 | to the image itself, it is the color of the webpage background against 154 | which the image is composited. Your eyes require a wavelength there 155 | and {!Gg.Color.void} cannot provide it. 156 | 157 | {!Vg.I.val-cut} has an optional [area] argument of type {!Vg.P.area} that 158 | determines how a path should be interpreted as an area of the 159 | plane. The default value is [`Anz], which means that it uses the 160 | non-zero winding number rule and for [circle] that defines its 161 | interior. 162 | 163 | But the [circle] path can also be seen as defining a thin outline area 164 | around the ideal mathematical circle of [circle]. This can be 165 | specified by using an outline area `O o. The value [o] of type 166 | {!Vg.P.outline} defines various parameters that define the outline area; 167 | for example its width. The following code cuts the [circle] outline 168 | area of width [0.04] in an infinite black image. 169 | 170 | {[ 171 | let circle_outline = 172 | let area = `O { P.o with P.width = 0.04 } in 173 | let blue = I.const (Color.v_srgb 0.000 0.439 0.722) in 174 | I.cut ~area circle blue 175 | ]} 176 | 177 | Below is the result and again, except for the blue color, the rest is in fact 178 | {!Gg.Color.void}. 179 | 180 | {%html: %} 182 | 183 | {!Vg.I.val-cut} gives us scissors but to combine the results of cuts we 184 | need some glue: the {!Vg.I.val-blend} combinator. This combinator takes 185 | two infinite images [front] and [back] and defines an image [I.blend 186 | front back] that has the colors of [front] alpha blended on top of 187 | those of [back]. [I.blend front back] represents this function: 188 | 189 | {[ 190 | let i' = fun pt -> Color.blend (front pt) (back pt) 191 | ]} 192 | 193 | If we blend [circle_outline] on top of [gray_circle]: 194 | 195 | {[ 196 | let dot = I.blend circle_outline gray_circle 197 | ]} 198 | 199 | We get: 200 | 201 | {%html: %} 203 | 204 | The order of arguments in {!I.val-blend} is defined so that images can 205 | be blended using the left-associative composition operator [|>]. That 206 | is [dot] can also be written as follows: 207 | 208 | {[ 209 | let dot = gray_circle |> I.blend circle_outline 210 | ]} 211 | 212 | This means that with [|>] and {!Vg.I.val-blend} left to right order in 213 | code maps to back to front image blending. 214 | 215 | {1:transforming Transforming images} 216 | 217 | The combinators {!Vg.I.move}, {!Vg.I.rot}, {!Vg.I.scale}, and 218 | {!Vg.I.tr} allow to perform arbitrary 219 | {{:http://mathworld.wolfram.com/AffineTransformation.html}affine 220 | transformations} on an image. For example the image [I.move v i] is 221 | [i] but translated by the vector [v], that is the following function: 222 | 223 | {[ 224 | fun pt -> img (V2.(pt - v)) 225 | ]} 226 | 227 | The following example uses {!Vg.I.move}. The function [scatter_plot] 228 | takes a list of points and returns a scatter plot of the points. First 229 | we define a [dot] around the origin, just a black circle of diameter 230 | [pt_width]. Second we define the function [mark] that given a point 231 | returns an image with [dot] at that point and [blend_mark] that blends 232 | a [mark] at a point on an image. Finally we blend all the marks 233 | together. 234 | 235 | {[ 236 | let scatter_plot pts pt_width = 237 | let dot = 238 | let circle = P.empty |> P.circle P2.o (0.5 *. pt_width) in 239 | I.const (Color.v_srgb 0.000 0.439 0.722) |> I.cut circle 240 | in 241 | let mark pt = dot |> I.move pt in 242 | let blend_mark acc pt = acc |> I.blend (mark pt) in 243 | List.fold_left blend_mark I.void pts 244 | ]} 245 | 246 | 247 | Note that [dot] is defined outside [mark], this means that all [mark]s 248 | share the same [dot], doing so allows renderers to perform space and 249 | time optimizations. For example the SVG renderer will output a single 250 | [circle] path shared by all marks. 251 | 252 | Here's the result of [scatter_point] on 800 points with coordinates 253 | on independent normal distributions. 254 | 255 | {%html: %} 257 | 258 | {1:paths Paths} 259 | 260 | Paths are used to define areas of the plane. A path is an immutable 261 | value of type {!Vg.path} which is a list of disconnected subpaths. A {e 262 | subpath} is a list of directed and connected curved segments. 263 | 264 | To build a path you start with the empty path {!Vg.P.empty}, give it 265 | to {!Vg.P.sub} to start a new subpath and give the result to 266 | {!Vg.P.line}, {!Vg.P.qcurve}, {!Vg.P.ccurve}, {!Vg.P.earc} or {!Vg.P.close} 267 | to add a new segment and so forth. 268 | 269 | Path combinators take the path they act upon as the last argument so 270 | that the left-associative operator [|>] can be used to construct 271 | paths. 272 | 273 | The image below is made by cutting the outline of the single path [p] 274 | defined hereafter. 275 | 276 | {%html: %} 278 | {[ 279 | let p = 280 | let rel = true in 281 | P.empty |> 282 | P.sub (P2.v 0.1 0.5) |> 283 | P.line (P2.v 0.3 0.5) |> 284 | P.qcurve ~rel (P2.v 0.2 0.5) (P2.v 0.2 0.0) |> 285 | P.ccurve ~rel (P2.v 0.0 (-. 0.5)) (P2.v 0.1 (-. 0.5)) (P2.v 0.3 0.0) |> 286 | P.earc ~rel (Size2.v 0.1 0.2) (P2.v 0.15 0.0) |> 287 | P.sub (P2.v 0.18 0.26) |> 288 | P.qcurve ~rel (P2.v (0.01) (-0.1)) (P2.v 0.1 (-. 0.05)) |> 289 | P.close |> 290 | P.sub (P2.v 0.65 0.8) |> 291 | P.line ~rel (P2.v 0.1 (-. 0.05)) 292 | in 293 | let area = `O { P.o with P.width = 0.01 } in 294 | I.const (Color.v_srgb 0.000 0.439 0.722) |> I.cut ~area p 295 | ]} 296 | 297 | Except for {!Vg.P.close} which has no other argument but a path, the 298 | last point argument before the path argument is always the concrete 299 | end point of the segment. When [true] the optional [rel] argument 300 | indicates that the coordinates given to the constructor are expressed 301 | relative to end point of the last segment (or [P2.o] if there is no 302 | such segment). 303 | 304 | Note that after a [P.close] or on the [P.empty] path, the call to 305 | {!P.sub} can be omitted. In that case an implicit [P.sub P2.o] is 306 | introduced. 307 | 308 | For more information about how paths are intepreted as areas, consult 309 | their {{!page-semantics.sempaths}semantics}. 310 | 311 | {1:remarkstips Remarks and tips} 312 | 313 | {ul 314 | {- Angles follow [Gg]'s {{!Gg.mathconv}conventions}.} 315 | {- Matrices given to {!Vg.P.tr} and {!Vg.I.tr} are supposed to 316 | be affine and as such ignore the last row of the matrix.} 317 | {- Do not rely on the output of printer functions, they 318 | are subject to change.} 319 | {- Rendering results are undefined if path 320 | or image data contains NaNs or infinite floats.} 321 | {- Any string is assumed to be UTF-8 encoded.} 322 | {- Sharing (sub)image, path and outline 323 | values in the definition of an image may result in more 324 | efficient rendering in space and time.}} 325 | -------------------------------------------------------------------------------- /opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | name: "vg" 3 | synopsis: "Declarative 2D vector graphics for OCaml" 4 | description: """\ 5 | Vg is a declarative 2D vector graphics library. Images are values that 6 | denote functions mapping points of the cartesian plane to colors and 7 | combinators are provided to define and compose them. 8 | 9 | Renderers for PDF, SVG, Cairo and the HTML canvas are distributed with the 10 | module. An API allows to implement new renderers. 11 | 12 | Vg is distributed under the ISC license. Vg and the SVG renderer 13 | depend on [Gg]. The PDF renderer depends on [Otfm], the HTML canvas 14 | renderer depends on [Brr], the Cairo renderer depends on [cairo2]. 15 | 16 | [Gg]: http://erratique.ch/software/gg 17 | [Otfm]: http://erratique.ch/software/otfm 18 | [Brr]: http://erratique.ch/software/brr 19 | [cairo2]: https://github.com/Chris00/ocaml-cairo 20 | 21 | Home page: http://erratique.ch/software/vg""" 22 | maintainer: "Daniel Bünzli " 23 | authors: "The vg programmers" 24 | license: "ISC" 25 | tags: [ 26 | "pdf" 27 | "svg" 28 | "canvas" 29 | "cairo" 30 | "browser" 31 | "declarative" 32 | "graphics" 33 | "org:erratique" 34 | ] 35 | homepage: "https://erratique.ch/software/vg" 36 | doc: "https://erratique.ch/software/vg/doc" 37 | bug-reports: "https://github.com/dbuenzli/vg/issues" 38 | depends: [ 39 | "ocaml" {>= "4.14.0"} 40 | "ocamlfind" {build} 41 | "ocamlbuild" {build} 42 | "topkg" {build & >= "1.0.3"} 43 | "gg" {>= "1.0.0"} 44 | ] 45 | depopts: ["brr" "cairo2" "otfm"] 46 | conflicts: [ 47 | "brr" {< "0.0.6"} 48 | "cairo2" {< "0.6"} 49 | "otfm" {< "0.3.0"} 50 | ] 51 | build: [ 52 | "ocaml" 53 | "pkg/pkg.ml" 54 | "build" 55 | "--dev-pkg" 56 | "%{dev}%" 57 | "--with-brr" 58 | "%{brr:installed}%" 59 | "--with-cairo2" 60 | "%{cairo2:installed}%" 61 | "--with-otfm" 62 | "%{otfm:installed}%" 63 | ] 64 | dev-repo: "git+https://erratique.ch/repos/vg.git" 65 | -------------------------------------------------------------------------------- /pkg/META: -------------------------------------------------------------------------------- 1 | description = "Declarative 2D vector graphics for OCaml" 2 | version = "%%VERSION_NUM%%" 3 | requires = "gg" 4 | archive(byte) = "vg.cma" 5 | archive(native) = "vg.cmxa" 6 | plugin(byte) = "vg.cma" 7 | plugin(native) = "vg.cmxs" 8 | exists_if = "vg.cma vg.cmxa" 9 | 10 | package "cairo" ( 11 | directory = "cairo" 12 | description = "The vg.cairo library" 13 | version = "%%VERSION_NUM%%" 14 | requires = "gg vg cairo2" 15 | archive(byte) = "vg_cairo.cma" 16 | archive(native) = "vg_cairo.cmxa" 17 | plugin(byte) = "vg_cairo.cma" 18 | plugin(native) = "vg_cairo.cmxs" 19 | exists_if = "vg_cairo.cma vg_cairo.cmxa" 20 | ) 21 | 22 | package "htmlc" ( 23 | directory = "htmlc" 24 | description = "The vg.htmlc library" 25 | version = "%%VERSION_NUM%%" 26 | requires = "gg vg brr" 27 | archive(byte) = "vg_htmlc.cma" 28 | archive(native) = "vg_htmlc.cmxa" 29 | plugin(byte) = "vg_htmlc.cma" 30 | plugin(native) = "vg_htmlc.cmxs" 31 | exists_if = "vg_htmlc.cma vg_htmlc.cmxa" 32 | ) 33 | 34 | package "pdf" ( 35 | directory = "pdf" 36 | description = "The vg.pdf library" 37 | version = "%%VERSION_NUM%%" 38 | requires = "gg vg otfm" 39 | archive(byte) = "vg_pdf.cma" 40 | archive(native) = "vg_pdf.cmxa" 41 | plugin(byte) = "vg_pdf.cma" 42 | plugin(native) = "vg_pdf.cmxs" 43 | exists_if = "vg_pdf.cma vg_pdf.cmxa" 44 | ) 45 | 46 | package "svg" ( 47 | description = "The vg.svg library (deprecated)" 48 | version = "%%VERSION_NUM%%" 49 | requires = "vg" 50 | exports = "vg" 51 | warning = "Deprecated, use the vg library." 52 | ) 53 | -------------------------------------------------------------------------------- /pkg/pkg.ml: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env ocaml 2 | #use "topfind" 3 | #require "topkg" 4 | open Topkg 5 | 6 | let brr = Conf.with_pkg "brr" 7 | let cairo2 = Conf.with_pkg "cairo2" 8 | let otfm = Conf.with_pkg "otfm" 9 | 10 | let doc_images () = 11 | let is_dir p = OS.Dir.exists p |> Log.on_error_msg ~use:(fun _ -> false) in 12 | let skip p = not (Fpath.has_ext ".png" p) && not (is_dir p) in 13 | let mv acc p = (Pkg.doc ~built:false p ~dst:"odoc-assets/") :: acc in 14 | OS.File.fold ~skip (fun p acc -> p :: acc) [] ["doc"] 15 | >>= fun files -> Ok (Pkg.flatten (List.fold_left mv [] files)) 16 | 17 | let () = 18 | Pkg.describe "vg" @@ fun c -> 19 | let brr = Conf.value c brr in 20 | let cairo2 = Conf.value c cairo2 in 21 | let otfm = Conf.value c otfm in 22 | doc_images () >>= fun doc_images -> 23 | Ok [ 24 | Pkg.mllib "src/vg.mllib"; 25 | Pkg.mllib ~cond:otfm "src/pdf/vg_pdf.mllib" ~dst_dir:"pdf"; 26 | Pkg.mllib ~cond:brr "src/htmlc/vg_htmlc.mllib" ~dst_dir:"htmlc"; 27 | Pkg.mllib ~cond:cairo2 "src/cairo/vg_cairo.mllib" ~dst_dir:"cairo"; 28 | 29 | Pkg.bin ~cond:otfm "test/vecho"; 30 | Pkg.doc "doc/index.mld" ~dst:"odoc-pages/index.mld"; 31 | Pkg.doc "doc/tutorial.mld" ~dst:"odoc-pages/tutorial.mld"; 32 | Pkg.doc "doc/semantics.mld" ~dst:"odoc-pages/semantics.mld"; 33 | Pkg.doc "doc/image_howto.mld" ~dst:"odoc-pages/image_howto.mld"; 34 | doc_images; ] 35 | -------------------------------------------------------------------------------- /src/cairo/vg_cairo.mllib: -------------------------------------------------------------------------------- 1 | Vgr_cairo 2 | -------------------------------------------------------------------------------- /src/cairo/vgr_cairo.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2014 The vg programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | open Gg 7 | open Vg 8 | open Vgr.Private.Data 9 | 10 | type cairo_font = Font : 'a Cairo.Font_face.t -> cairo_font 11 | type cairo_primitive = Pattern : 'a Cairo.Pattern.t -> cairo_primitive 12 | 13 | let dumb_prim = Pattern (Cairo.Pattern.create_rgba 0.0 0.0 0.0 0.0) 14 | 15 | type gstate = (* subset of the graphics state saved by a Cairo.save ctx *) 16 | { mutable g_tr : M3.t; (* current transform without view_tr. *) 17 | mutable g_outline : P.outline; (* current outline stroke. *) 18 | mutable g_stroke : cairo_primitive; (* current stroke color. *) 19 | mutable g_fill : cairo_primitive; } (* current fill color. *) 20 | 21 | let init_gstate = 22 | { g_tr = M3.id; g_outline = P.o; g_stroke = dumb_prim; g_fill = dumb_prim } 23 | 24 | type cmd = Set of gstate | Draw of Vgr.Private.Data.image 25 | type state = 26 | { r : Vgr.Private.renderer; (* corresponding renderer. *) 27 | ctx : Cairo.context; (* cairo context. *) 28 | mutable cost : int; (* cost counter for limit. *) 29 | mutable view : Gg.box2; (* current renderable view rectangle. *) 30 | mutable todo : cmd list; (* commands to perform. *) 31 | fonts : (Vg.font, cairo_font) Hashtbl.t; (* cached fonts. *) 32 | prims : (* cached primitives. *) 33 | (Vgr.Private.Data.primitive, cairo_primitive) Hashtbl.t; 34 | mutable gstate : gstate; } (* current graphic state. *) 35 | 36 | let create_state r ctx = 37 | { r; ctx; 38 | cost = 0; 39 | view = Box2.empty; 40 | todo = []; 41 | fonts = Hashtbl.create 20; 42 | prims = Hashtbl.create 231; 43 | gstate = init_gstate; } 44 | 45 | let save_gstate s = Set { s.gstate with g_tr = s.gstate.g_tr } 46 | let set_gstate s g = s.gstate <- g 47 | 48 | let partial = Vgr.Private.partial 49 | let limit s = Vgr.Private.limit s.r 50 | let warn s w = Vgr.Private.warn s.r w 51 | let image i = Vgr.Private.I.of_data i 52 | 53 | let view_rect s = (* image view rect in current coordinate system. *) 54 | let tr = M3.inv s.gstate.g_tr in 55 | Vgr.Private.Data.of_path (P.empty |> P.rect (Box2.tr tr s.view)) 56 | 57 | let cairo_matrix xx yx xy yy x0 y0 = 58 | { Cairo.xx; yx; xy; yy; x0; y0 } 59 | 60 | let cairo_matrix_of_m3 m = 61 | M3.(cairo_matrix (e00 m) (e10 m) (e01 m) (e11 m) (e02 m) (e12 m)) 62 | 63 | let cairo_cap = function 64 | | `Butt -> Cairo.BUTT 65 | | `Round -> Cairo.ROUND 66 | | `Square -> Cairo.SQUARE 67 | 68 | let cairo_join = function 69 | | `Bevel -> Cairo.JOIN_BEVEL 70 | | `Round -> Cairo.JOIN_ROUND 71 | | `Miter -> Cairo.JOIN_MITER 72 | 73 | let cairo_fill_rule = function 74 | | `Anz -> Cairo.WINDING 75 | | `Aeo -> Cairo.EVEN_ODD 76 | | `O _ -> assert false 77 | 78 | let set_dashes s = function 79 | | None -> Cairo.set_dash s.ctx [||] 80 | | Some (offset, dashes) -> 81 | let dashes = Array.of_list dashes in 82 | Cairo.set_dash s.ctx ~ofs:offset dashes 83 | 84 | let init_ctx s size view_tr = 85 | let o = s.gstate.g_outline in 86 | (* Clear and clip surface *) 87 | Cairo.transform s.ctx (cairo_matrix_of_m3 M3.id); 88 | Cairo.set_operator s.ctx Cairo.CLEAR; 89 | Cairo.rectangle s.ctx 0. 0. ~w:(Size2.w size) ~h:(Size2.h size); 90 | Cairo.clip_preserve s.ctx; 91 | Cairo.fill s.ctx; 92 | (* Setup base state *) 93 | Cairo.set_operator s.ctx Cairo.OVER; 94 | Cairo.transform s.ctx (cairo_matrix_of_m3 view_tr); 95 | Cairo.set_line_width s.ctx o.P.width; 96 | Cairo.set_line_cap s.ctx (cairo_cap o.P.cap); 97 | Cairo.set_line_join s.ctx (cairo_join o.P.join); 98 | Cairo.set_miter_limit s.ctx (Vgr.Private.P.miter_limit o); 99 | set_dashes s o.P.dashes 100 | 101 | let push_transform s tr = 102 | let m = match tr with 103 | | Move v -> Cairo.translate s.ctx (V2.x v) (V2.y v); M3.move2 v 104 | | Rot a -> Cairo.rotate s.ctx a; M3.rot2 a 105 | | Scale sv -> Cairo.scale s.ctx (V2.x sv) (V2.y sv); M3.scale2 sv 106 | | Matrix m -> Cairo.transform s.ctx (cairo_matrix_of_m3 m); m 107 | in 108 | s.gstate.g_tr <- M3.mul s.gstate.g_tr m 109 | 110 | let set_outline s o = 111 | if s.gstate.g_outline == o then () else 112 | let old = s.gstate.g_outline in 113 | s.gstate.g_outline <- o; 114 | if old.P.width <> o.P.width then 115 | (Cairo.set_line_width s.ctx o.P.width); 116 | if old.P.cap <> o.P.cap then 117 | (Cairo.set_line_cap s.ctx (cairo_cap o.P.cap)); 118 | if old.P.join <> o.P.join then 119 | (Cairo.set_line_join s.ctx (cairo_join o.P.join)); 120 | if old.P.miter_angle <> o.P.miter_angle then 121 | (Cairo.set_miter_limit s.ctx (Vgr.Private.P.miter_limit o)); 122 | if old.P.dashes <> o.P.dashes then 123 | set_dashes s o.P.dashes; 124 | () 125 | 126 | let get_primitive s p = try Hashtbl.find s.prims p with 127 | | Not_found -> 128 | let add_stop g (t, c) = 129 | let c = Color.to_srgb c in 130 | Cairo.Pattern.add_color_stop_rgba g ~ofs:t 131 | (V4.x c) (V4.y c) (V4.z c) (V4.w c) 132 | in 133 | let create = function 134 | | Const c -> 135 | let c = Color.to_srgb c in 136 | Pattern V4.(Cairo.Pattern.create_rgba (x c) (y c) (z c) (w c)) 137 | | Axial (stops, pt, pt') -> 138 | let g = 139 | V2.(Cairo.Pattern.create_linear 140 | ~x0:(x pt) ~y0:(y pt) ~x1:(x pt') ~y1:(y pt')) 141 | in 142 | List.iter (add_stop g) stops; Pattern g 143 | | Radial (stops, f, c, r) -> 144 | let g = 145 | V2.(Cairo.Pattern.create_radial 146 | ~x0:(x f) ~y0:(y f) ~r0:0.0 ~x1:(x c) ~y1:(y c) ~r1:r) 147 | in 148 | List.iter (add_stop g) stops; Pattern g 149 | | Raster _ -> assert false 150 | in 151 | let prim = create p in 152 | Hashtbl.add s.prims p prim; prim 153 | 154 | let get_font s font = try Hashtbl.find s.fonts font with 155 | | Not_found -> 156 | let cairo_font = 157 | let slant = match font.Font.slant with 158 | | `Italic -> Cairo.Italic 159 | | `Normal -> Cairo.Upright 160 | | `Oblique -> Cairo.Oblique 161 | in 162 | let weight = match font.Font.weight with 163 | | `W700 | `W800 | `W900 -> Cairo.Bold 164 | | _ -> Cairo.Normal 165 | in 166 | Font (Cairo.Font_face.create ~family:font.Font.name slant weight) 167 | in 168 | Hashtbl.add s.fonts font cairo_font; cairo_font 169 | 170 | let set_source s p = 171 | let (Pattern g) as p = get_primitive s p in 172 | Cairo.set_source s.ctx g; 173 | p 174 | 175 | let set_stroke s p = s.gstate.g_stroke <- set_source s p 176 | let set_fill s p = s.gstate.g_fill <- set_source s p 177 | 178 | let set_font s font size = 179 | let Font f = get_font s font in 180 | Cairo.Font_face.set s.ctx f; 181 | Cairo.set_font_size s.ctx size 182 | 183 | let set_path s p = 184 | let rec loop last = function 185 | | [] -> () 186 | | seg :: segs -> 187 | match seg with 188 | | `Sub pt -> P2.(Cairo.move_to s.ctx (x pt) (y pt)); loop pt segs 189 | | `Line pt -> P2.(Cairo.line_to s.ctx (x pt) (y pt)); loop pt segs 190 | | `Qcurve (q, pt) -> 191 | let x,y = Cairo.Path.get_current_point s.ctx in 192 | let p0 = V2.v x y in 193 | let twoq = V2.(2. * q) in 194 | let c = V2.((p0 + twoq) / 3.) in 195 | let c' = V2.((pt + twoq) / 3.) in 196 | P2.(Cairo.curve_to s.ctx (x c) (y c) (x c') (y c') (x pt) (y pt)); 197 | loop pt segs 198 | | `Ccurve (c, c', pt) -> 199 | P2.(Cairo.curve_to s.ctx (x c) (y c) (x c') (y c') (x pt) (y pt)); 200 | loop pt segs 201 | | `Earc (large, cw, r, a, pt) -> 202 | begin match Vgr.Private.P.earc_params last ~large ~cw r a pt with 203 | | None -> P2.(Cairo.line_to s.ctx (x pt) (y pt)); loop pt segs 204 | | Some (c, m, a, a') -> 205 | Cairo.save s.ctx; 206 | let c = V2.ltr (M2.inv m) c in 207 | M2.(Cairo.transform s.ctx (cairo_matrix (e00 m) (e10 m) 208 | (e01 m) (e11 m) 209 | 0. 0.)); 210 | let arc = if cw then Cairo.arc_negative else Cairo.arc in 211 | P2.(arc s.ctx (x c) (y c) ~r:1.0 ~a1:a ~a2:a'); 212 | Cairo.restore s.ctx; 213 | loop pt segs 214 | end 215 | | `Close -> Cairo.Path.close s.ctx; loop last (* we don't care *) segs 216 | in 217 | Cairo.Path.clear s.ctx; 218 | loop P2.o (List.rev p) 219 | 220 | let rec r_cut s a = function 221 | | Primitive (Raster _) -> assert false 222 | | Primitive p -> 223 | begin match a with 224 | | `O o -> set_outline s o; set_stroke s p; Cairo.stroke s.ctx 225 | | `Aeo | `Anz -> 226 | set_fill s p; 227 | Cairo.set_fill_rule s.ctx (cairo_fill_rule a); 228 | Cairo.fill s.ctx 229 | end 230 | | Tr (tr, i) -> 231 | Cairo.save s.ctx; 232 | s.todo <- (save_gstate s) :: s.todo; 233 | push_transform s tr; 234 | r_cut s a i 235 | | Blend _ | Cut _ | Cut_glyphs _ as i -> 236 | let a = match a with 237 | | `O _ -> warn s (`Unsupported_cut (a, image i)); `Anz 238 | | a -> a 239 | in 240 | Cairo.save s.ctx; 241 | Cairo.set_fill_rule s.ctx (cairo_fill_rule a); 242 | Cairo.clip s.ctx; 243 | s.todo <- (Draw i) :: (save_gstate s) :: s.todo 244 | 245 | let rec r_cut_glyphs s a run i = match run.text with 246 | | None -> warn s (`Textless_glyph_cut (image (Cut_glyphs (a, run, i)))) 247 | | Some text -> 248 | Cairo.save s.ctx; 249 | s.todo <- (save_gstate s) :: s.todo; 250 | let font_size = run.font.Font.size in 251 | set_font s run.font font_size; 252 | Cairo.Path.clear s.ctx; 253 | Cairo.transform s.ctx (cairo_matrix 1.0 0.0 254 | 0.0 (-1.0) 255 | 0.0 0.0); 256 | Cairo.move_to s.ctx 0. 0.; 257 | Cairo.Path.text s.ctx text; 258 | begin match a with 259 | | `O o -> 260 | set_outline s o; 261 | begin match i with 262 | | Primitive p -> 263 | set_stroke s p; 264 | Cairo.stroke s.ctx 265 | | _ -> 266 | warn s (`Unsupported_glyph_cut (a, image i)) 267 | end 268 | | `Aeo | `Anz -> 269 | Cairo.clip s.ctx; 270 | Cairo.transform s.ctx (cairo_matrix 1.0 0.0 271 | 0.0 (-1.0) 272 | 0.0 0.0); 273 | s.todo <- Draw i :: s.todo 274 | end 275 | 276 | let rec r_image s k r = 277 | if s.cost > limit s then (s.cost <- 0; partial (r_image s k) r) else 278 | match s.todo with 279 | | [] -> k r 280 | | Set gs :: todo -> 281 | Cairo.restore s.ctx; 282 | set_gstate s gs; 283 | s.todo <- todo; 284 | r_image s k r 285 | | Draw i :: todo -> 286 | s.cost <- s.cost + 1; 287 | match i with 288 | | Primitive _ as i -> (* Uncut primitive, just cut to view. *) 289 | let p = view_rect s in 290 | s.todo <- (Draw (Cut (`Anz, p, i))) :: todo; 291 | r_image s k r 292 | | Cut (a, p, i) -> 293 | s.todo <- todo; 294 | set_path s p; 295 | r_cut s a i; 296 | r_image s k r 297 | | Cut_glyphs (a, run, i) -> 298 | s.todo <- todo; 299 | r_cut_glyphs s a run i; 300 | r_image s k r 301 | | Blend (_, _, i, i') -> 302 | s.todo <- (Draw i') :: (Draw i) :: todo; 303 | r_image s k r 304 | | Tr (tr, i) -> 305 | Cairo.save s.ctx; 306 | s.todo <- (Draw i) :: (save_gstate s) :: todo; 307 | push_transform s tr; 308 | r_image s k r 309 | 310 | let render_image s size view i k r = 311 | (* Map view rect (bot-left coords) to surface (top-left coords) *) 312 | let sx = Size2.w size /. Box2.w view in 313 | let sy = Size2.h size /. Box2.h view in 314 | let dx = -. Box2.ox view *. sx in 315 | let dy = Size2.h size +. Box2.oy view *. sy in 316 | let view_tr = M3.v sx 0. dx 317 | 0. (-. sy) dy 318 | 0. 0. 1. 319 | in 320 | s.cost <- 0; 321 | s.view <- view; 322 | s.todo <- [ Draw i ]; 323 | s.gstate <- { init_gstate with g_tr = init_gstate.g_tr }; (* copy *) 324 | Cairo.save s.ctx; 325 | init_ctx s size view_tr; 326 | r_image s (fun r -> Cairo.restore s.ctx; k r) r 327 | 328 | let target ctx = 329 | let render s v k r = match v with 330 | | `End -> k r 331 | | `Image (size, view, i) -> render_image s size view i k r 332 | in 333 | let target r _ = true, render (create_state r ctx) in 334 | Vgr.Private.create_target target 335 | 336 | (* Stored targets. *) 337 | 338 | let mm2pt = 72. /. 25.4 339 | 340 | let vgr_output r str = 341 | ignore (Vgr.Private.writes str 0 (String.length str) (fun _ -> `Ok) r) 342 | 343 | let stored_state r backend size = 344 | let scale = match backend with 345 | | `Png res -> V2.(res / 1000.) 346 | | `Pdf | `Ps | `Svg -> V2.v mm2pt mm2pt 347 | in 348 | let w = Size2.w size *. (V2.x scale) in 349 | let h = Size2.h size *. (V2.y scale) in 350 | let surface = match backend with 351 | | `Png _ -> 352 | Cairo.Image.(create ARGB32 ~w:(int_of_float w) ~h:(int_of_float h)) 353 | | `Pdf -> Cairo.PDF.create_for_stream (vgr_output r) ~w ~h 354 | | `Ps -> Cairo.PS.create_for_stream (vgr_output r) ~w ~h 355 | | `Svg -> Cairo.SVG.create_for_stream (vgr_output r) ~w ~h 356 | in 357 | let ctx = Cairo.create surface in 358 | Cairo.scale ctx (V2.x scale) (V2.y scale); 359 | create_state r ctx 360 | 361 | let stored_render backend = 362 | let state = ref None in 363 | fun v k r -> match v with 364 | | `End -> 365 | begin match !state with 366 | | None -> () 367 | | Some s -> 368 | let surf = Cairo.get_target s.ctx in 369 | begin match backend with 370 | | `Png _ -> Cairo.PNG.write_to_stream surf (vgr_output r); 371 | | `Svg | `Pdf | `Ps -> () 372 | end; 373 | Cairo.Surface.finish surf 374 | end; 375 | Vgr.Private.flush k r 376 | | `Image (size, view, i) -> 377 | let s = match !state with 378 | | None -> let s = stored_state r backend size in (state := Some s; s) 379 | | Some s -> s 380 | in 381 | let set_page_size set = 382 | let surf = Cairo.get_target s.ctx in 383 | set surf ~w:(Size2.w size *. mm2pt) ~h:(Size2.h size *. mm2pt) 384 | in 385 | begin match backend with 386 | | `Png _ -> () 387 | | `Svg -> () 388 | | `Pdf -> set_page_size Cairo.PDF.set_size 389 | | `Ps -> set_page_size Cairo.PS.set_size 390 | end; 391 | render_image s size view i (fun r -> Cairo.show_page s.ctx; k r) r 392 | 393 | let stored_target backend = 394 | let multi = match backend with `Pdf | `Ps -> true | `Svg | `Png _ -> false in 395 | let target _ _ = multi, stored_render backend in 396 | Vgr.Private.create_target target 397 | -------------------------------------------------------------------------------- /src/cairo/vgr_cairo.mli: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2014 The vg programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | (** {{:http://cairographics.org/}Cairo} renderer. *) 7 | 8 | (** {1:target Cairo render targets} *) 9 | 10 | val target : Cairo.context -> [`Other] Vg.Vgr.target 11 | (** [target ctx] is a render target for rendering to the Cairo 12 | context [ctx]. Rendering a {{!Vg.Vgr.type-renderable}renderable} 13 | [(size, view, i)] is done as follows. 14 | {ol 15 | {- The context's current state is saved using {!Cairo.save}.} 16 | {- The context's is clipped to [Box2.v P2.o size]. This 17 | box is cleared with {!Color.void} and the portion 18 | [view] of [i] is rendered in this box.} 19 | {- The context's initial state is restored using {!Cairo.restore}}} 20 | Nothing else is done to [ctx]. 21 | 22 | {b Multiple images.} Multiple images rendering is supported. For 23 | each renderable the above procedure is performed on [ctx]. If you 24 | want to have each renderable on a single page on backends that support 25 | it you should handle this between two renderable using Cairo's API. *) 26 | 27 | val stored_target : [< `Pdf | `Png of Gg.V2.t | `Ps | `Svg ] -> 28 | Vg.Vgr.dst_stored Vg.Vgr.target 29 | (** [stored_target fmt] is a [fmt] render target for rendering to 30 | the stored destination given to {!Vg.Vgr.create}. For [`Png] 31 | the argument specifies the rendering resolution in samples 32 | per meters. 33 | 34 | {b Multiple images.} Multiple image rendering is supported on 35 | [`Pdf] and [`Ps] target, each renderable creates a new page of the 36 | renderable size. Multiple image rendering is not supported on 37 | [`Png] and [`Svg] and [Invalid_argument] is raised by 38 | {!Vg.Vgr.val-render} if multiple images are rendered. *) 39 | 40 | (** {1:text Text rendering} 41 | 42 | {b Warning.} The following is subject to change in the future. 43 | 44 | Currently text rendering uses Cairo's font selection mechanism 45 | and doesn't support the glyph API. 46 | 47 | Given a glyph cut: 48 | 49 | {!Vg.I.cut_glyphs}[ ~text ~blocks ~advances font glyphs] 50 | 51 | The [blocks], [advances] and [glyphs] parameters are ignored. 52 | [text] must be provided and is used to define the text to render. 53 | [font] is used to select the font family. 54 | 55 | The weight is limited to Normal ([< `W700]) and Bold ([>= `W700]). 56 | 57 | {1:limits Render warnings and limitations} 58 | 59 | The following render warnings are reported. 60 | {ul 61 | {- [`Unsupported_cut (`O o, i)], outline area cuts can be performed 62 | only on (possibly transformed) {!Vg.I.const}, {!Vg.I.axial} and 63 | {!Vg.I.radial} images.} 64 | {- [`Unsupported_glyph_cut (`O o, i)], outline glyph cuts can be 65 | performed only on (untransformed) {!Vg.I.const}, {!Vg.I.axial} 66 | and {!Vg.I.radial} images.} 67 | {- [`Textless_glyph_cut i] if no [text] argument is specified in a 68 | glyph cut.}} 69 | 70 | The following limitations should be taken into account. 71 | {ul 72 | {- In Cairo, the gradient color interpolation is performed 73 | in (non-linear) sRGB space. This doesn't respect Vg's semantics.}} *) 74 | -------------------------------------------------------------------------------- /src/htmlc/vg_htmlc.mllib: -------------------------------------------------------------------------------- 1 | Vgr_htmlc 2 | -------------------------------------------------------------------------------- /src/htmlc/vgr_htmlc.mli: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2013 The vg programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | (** HTML canvas renderer. 7 | 8 | {b References.} 9 | {ul {- Rik Cabanier et al. {e {{:http://www.w3.org/TR/2dcontext/}HTML 10 | Canvas 2D Context}}, 2012-12-17.}} *) 11 | 12 | (** {1:target HTML canvas render targets} *) 13 | 14 | val screen_resolution : unit -> Gg.v2 15 | (** [screen_resolution ()] is the screen resolution in pixels per meters. *) 16 | 17 | val target : 18 | ?resize:bool -> ?resolution:Gg.v2 -> 'a -> [`Other] Vg.Vgr.target 19 | (** [target resize resolution c] is a render target for rendering to the 20 | canvas element [c] (you need to make sure this is an 21 | {{:https://developer.mozilla.org/en-US/docs/Web/API/HTMLCanvasElement} 22 | HTMLCanvasElement} JavaScript object otherwise a runtime error will 23 | occur). 24 | {ul 25 | {- [resize] if [true] (default) sets the canvas CSS size to the 26 | physical size of {{!Vg.Vgr.type-renderable}renderables}. If [false] 27 | the physical size of renderables is ignored and the view 28 | rectangle is simply mapped on the canvas CSS size at the given 29 | resolution but {b WARNING} for this to work do not use any 30 | CSS [border] on the canvas element ([outline] can be used though) 31 | as it interacts badly with the underlying canvas size computation 32 | made by [Vgr_htmlc] (a typical symptom will be a vertically growing 33 | canvas on redraws, this seems to happen regardless of [box-sizing]).} 34 | {- [resolution], specifies the rendering resolution in samples per 35 | meters. If unspecified the {!screen_resolution} is used in both 36 | dimensions.}} 37 | 38 | {b Multiple images.} Multiple images render on the target is supported. 39 | Each new render clears the HTML canvas. *) 40 | 41 | (** {1:text Text rendering} 42 | 43 | Text rendering uses the HTML canvas CSS font selection mechanism. 44 | As there is no control over glyph rendering in the HTML canvas, 45 | the glyph API is unsupported. 46 | 47 | Given a glyph cut: 48 | 49 | {!Vg.I.cut_glyphs}[ ~text ~blocks ~advances font glyphs] 50 | 51 | The [blocks], [advances] and [glyphs] parameters are ignored. 52 | [text] must be provided and is used to define the text to render. 53 | [font] is used to select the font in the CSS stylesheet. Make sure 54 | that the fonts you use are embedded and {b loaded} in your DOM via 55 | [\@font-face]. 56 | 57 | At the moment the renderer also needs to work around a particular 58 | browser bug which means that glyph cuts are currently limited to 59 | non-outline area cuts in {!Vg.I.const} images. *) 60 | 61 | (** {1:limits Render warnings and limitations} 62 | 63 | The following render warnings are reported. 64 | {ul 65 | {- [`Unsupported_cut ((`O o), i)], outline area cuts can be performed 66 | only on (possibly transformed) {!Vg.I.const}, 67 | {!Vg.I.axial} and {!Vg.I.radial} 68 | primitive images.} 69 | {- [`Unsupported_glyph_cut (a, i)], glyph cuts can be performed only 70 | on bare {!Vg.I.const} primitive images and outline area glyph cuts are 71 | currently unsupported.} 72 | {- [`Textless_glyph_cut i] if no [text] argument is specified in a glyph 73 | cut.} 74 | {- [`Other _] if dashes are rendered but unsupported by the browser.}} 75 | 76 | The following limitations should be taken into account. 77 | {ul 78 | {- The even-odd area rule is supported according to the 79 | latest whatwg spec. This may not work in all browsers.} 80 | {- In the HTML canvas gradient color interpolation is performed 81 | in (non-linear) sRGB space. This doesn't respect Vg's semantics.}} *) 82 | -------------------------------------------------------------------------------- /src/pdf/vg_pdf.mllib: -------------------------------------------------------------------------------- 1 | Vgr_pdf -------------------------------------------------------------------------------- /src/pdf/vgr_pdf.mli: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2013 The vg programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | (** PDF renderer. 7 | 8 | Renders a sequence of renderables as a multi-page PDF 1.7 9 | document. Each renderable defines a page of the document. 10 | 11 | {b Bug reports.} PDF being an insane standard, rendering 12 | abilities of PDF readers vary wildly. No rendering bug report for 13 | this renderer will be considered if it cannot be reproduced in the 14 | latest Adobe Acrobat Reader. *) 15 | 16 | (** {1:fonts Font resolution} 17 | 18 | Font resolution happens during the rendering of {!Vg.I.cut_glyphs} 19 | images through the [font] callback given to the PDF rendering {!val-target}. 20 | See {!text} for more details. *) 21 | 22 | type otf_font 23 | (** The type for OpenType fonts. *) 24 | 25 | val otf_font : string -> ([> `Otf of otf_font], Otfm.error) result 26 | (** [otf_font bytes] is an OpenType font from the OpenType byte 27 | serialization [bytes]. *) 28 | 29 | type font = 30 | [ `Otf of otf_font 31 | | `Serif | `Sans | `Fixed 32 | | `Helvetica | `Times | `Courier ] 33 | (** The type for font resolution results. Any case different from [`Otf] 34 | ends up using the PDF standard fonts. See {!text} for details. *) 35 | 36 | val font : Vg.font -> font 37 | (** [font] is the default font resolver. Given a {!Vg.font} [f] it performs the 38 | following resolutions according to value of [f.Font.name]: 39 | {ul 40 | {- ["Helvetica"], returns [`Sans]} 41 | {- ["Times"], returns [`Serif]} 42 | {- ["Courier"], returns [`Fixed]} 43 | {- Any other, returns [`Sans]}} 44 | See {!text} for understanding what this entails. *) 45 | 46 | (** {1:target PDF render targets} *) 47 | 48 | val target : 49 | ?font:(Vg.font -> font) -> ?xmp:string -> unit -> 50 | Vg.Vgr.dst_stored Vg.Vgr.target 51 | (** [target font xmp ()] is a PDF render target for rendering to the stored 52 | destination given to {!Vg.Vgr.create}. 53 | {ul 54 | {- [font] is the font resolver, defaults to {!val:font}, see {!text} for 55 | details. Note that [font] results are cached by the renderer.} 56 | {- [xmp] is an optional UTF-8 encoded XML XMP metadata packet describing 57 | the PDF document (see ISO 16684-1 or the equivalent 58 | {{:http://www.adobe.com/devnet/xmp.html}Adobe spec.}). 59 | The convenience function {!Vg.Vgr.xmp} can be used to 60 | generate a packet.}} 61 | 62 | {b Multiple image.} Multiple image render is supported. Each image 63 | defines a page of the resulting PDF file. *) 64 | 65 | (** {1:text Text rendering} 66 | 67 | Text rendering depends on the way fonts are resolved by the 68 | function specified in the rendering {!val-target}. Given a glyph 69 | cut: 70 | 71 | {!Vg.I.cut_glyphs}[ ~text ~blocks ~advances font glyphs] 72 | 73 | First, if the optional [text] and [blocks] arguments are 74 | specified, they are always used to map the rendered glyphs to 75 | text for PDF text extraction. Then the following happens 76 | according to the resolution of the [font] argument by the render 77 | target: 78 | {ul 79 | {- [`Otf otf], the values in [glyphs] are glyph indexes of 80 | the OpenType font [otf]. If [advances] is specified these vectors 81 | are used to position the glyphs (e.g. you need to use this to perform 82 | kerning), otherwise the font's glyph advances, as found in [otf], are 83 | used.} 84 | {- [`Helvetica], uses one of the standard PDF font Helvetica, 85 | Helvetica-Bold, Helvetica, Helvetica-Bold, Helvetica-Oblique, 86 | Helvetica-BoldOblique according to [font]'s {!Vg.Font.type-slant} and 87 | {!Vg.Font.type-weight}. The values in [glyphs] are glyph indexes 88 | representing the corresponding Unicode character (e.g. glyph 89 | index [0x20] is the glyph for character [U+0020]). The font 90 | supports glyph indexes for all the characters listed in the in 91 | the second column of 92 | {{:http://www.unicode.org/Public/MAPPINGS/VENDORS/MICSFT/WINDOWS/CP1252.TXT} 93 | this document} which is all the Basic Latin block, the Latin-1 94 | Supplement block without its control characters and some 95 | additional characters (those at rows 0x80-0x9F in that document). 96 | If a glyph index is not supported it is replaced by [0]. If 97 | [advances] is specified these vectors are used to position the glyphs, 98 | otherwise the internal font's glyphs advances are used.} 99 | {- [`Times], same as [`Helvetica] but uses one of the standard PDF font 100 | Times-Roman, Times-Bold, Times-Italic or Times-BoldItalic.} 101 | {- [`Courier], same as [`Helvetica] but uses one of the standard PDF font 102 | Courier, Courier-Bold, Courier-Oblique, Courier-BoldOblique.} 103 | {- [`Sans] is the same as [`Helvetica] except [advances] and [glyphs] 104 | are {b ignored}. Instead the UTF-8 string [text] is used to generate 105 | a corresponding [glyphs] list, mapping supported characters as mentioned 106 | above to their corresponding glyph. Unsupported characters are 107 | mapped to glyph 0.} 108 | {- [`Serif] same as [`Sans] but uses the same fonts as [`Times].} 109 | {- [`Fixed] same as [`Sans] but uses the same fonts as [`Courier].}} 110 | 111 | So what should be used ? In general clients should use a font 112 | resolution mechanism independent from [Vg] in order to get an 113 | OpenType font [otf] for [font]. Using this [otf] font is should 114 | compute, using again a mechanism independent from [Vg], a glyph 115 | layout resulting in [advances] and [glyphs] to use with 116 | {!Vg.I.cut_glyphs} and finally resolve [font] in the target with 117 | [`Otf otf]. This means that font resolution should: 118 | {ul 119 | {- Use [`Otf otf] whenever it is guaranteed that the glyph indexes 120 | in [glyphs] actually correspond to the glyph indexes of [otf].} 121 | {- Use [`Sans], [`Serif] or [`Fixed] whenever its is unable to resolve 122 | [font] to an appropriate [otf], this may not result in the expected 123 | rendering but still at least show (the latin) part of the text.} 124 | {- Use [`Helvetica], [`Times] or [`Courier] to perform glyph 125 | layout using PDF's standard fonts without having to embed the fonts in 126 | the PDF (the font metrics can be downloaded 127 | {{:https://www.adobe.com/devnet/font.html}here}). 128 | PDFs without embedded fonts are however not recommended.}} *) 129 | 130 | (** {1:limits Render warnings and limitations} 131 | 132 | The following render warnings are reported. 133 | {ul 134 | {- [`Unsupported_cut (`O o, i)], outline area cuts can be performed only 135 | on (possibly transformed) {!Vg.I.const}, {!Vg.I.axial}, {!Vg.I.radial} 136 | images.} 137 | {- [`Unsupported_glyph_cut (`O o, i)], outline area glyph cuts can 138 | be performed only on (possibly transformed) {!Vg.I.const}, 139 | {!Vg.I.axial}, {!Vg.I.radial} images.}} 140 | 141 | The following limitations should be taken into account: 142 | {ul 143 | {- Streams in the PDF files are currently uncompressed and fonts 144 | are embedded without subsetting which may result in large file 145 | sizes. This will be lifted in future versions of the 146 | library. Meanwhile if you need to reduce the size of generated 147 | PDFs you can pass them through 148 | {{:http://community.coherentpdf.com}cpdf} or 149 | {{:http://www.ghostscript.com}ghostscript}. 150 | {v 151 | > cpdf -compress -o output.pdf input.pdf 152 | > gs -dNOPAUSE -dBATCH -sDEVICE=pdfwrite -sOutputFile=output.pdf input.pdf 153 | v}}} 154 | *) 155 | -------------------------------------------------------------------------------- /src/vg.mllib: -------------------------------------------------------------------------------- 1 | Vg 2 | Vgr_svg -------------------------------------------------------------------------------- /src/vgr_svg.mli: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2013 The vg programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | (** SVG renderer. 7 | 8 | {b References.} 9 | {ul {- Erik Dahlström et al. {{:http://www.w3.org/TR/SVG11/}{e 10 | Scalable Vector Graphics (SVG) 1.1}}, 2011.}} *) 11 | 12 | (** {1:target SVG render targets} *) 13 | 14 | val target : ?xml_decl:bool -> ?xmp:string ->unit -> 15 | Vg.Vgr.dst_stored Vg.Vgr.target 16 | (** [target xml_decl xmp ()] is an SVG render target for rendering to the 17 | stored destination given to {!Vg.Vgr.create}. 18 | {ul 19 | {- [xml_decl], if [true] (default) the 20 | {{:http://www.w3.org/TR/REC-xml/#NT-XMLDecl}XML declaration} is 21 | output.} 22 | {- [xmp] is an optional UTF-8 encoded XML XMP metadata packet describing 23 | the SVG document (see ISO 16684-1 or the equivalent 24 | {{:http://www.adobe.com/devnet/xmp.html}Adobe spec.}). 25 | The convenience function {!Vg.Vgr.xmp} can be used to 26 | generate a packet.}} 27 | 28 | {b Multiple images.} Multiple image renders on the target are not 29 | supported. [Invalid_argument] is raised by {!Vg.Vgr.val-render} if multiple 30 | images are rendered. *) 31 | 32 | (** {1:text Text rendering} 33 | 34 | {b Warning.} The following is subject to change in the future. 35 | 36 | Currently text rendering uses SVG's CSS font selection mechanism 37 | and doesn't support the glyph API. 38 | 39 | Given a glyph cut: 40 | 41 | {!Vg.I.cut_glyphs}[ ~text ~blocks ~advances font glyphs] 42 | 43 | The [blocks], [advances] and [glyphs] parameters are ignored. 44 | [text] must be provided and is used to define the text to render. 45 | [font] is used to select the font in a CSS stylesheet. *) 46 | 47 | (** {1:limits Render warnings and limitations} 48 | 49 | The following render warnings are reported. 50 | {ul 51 | {- [`Unsupported_cut (`O o, i)], outline area cuts can be performed 52 | only on (possibly transformed) {!Vg.I.const}, {!Vg.I.axial} and 53 | {!Vg.I.radial} images.} 54 | {- [`Unsupported_glyph_cut (a, i)], glyph cuts can be performed 55 | only on (untransformed) {!Vg.I.const}, {!Vg.I.axial} and 56 | {!Vg.I.radial} images.} 57 | {- [`Textless_glyph_cut i] if no [text] argument is specified in a 58 | glyph cut.}} 59 | 60 | The following limitations should be taken into account. 61 | {ul 62 | {- Generated SVG files do specify that gradient interpolation 63 | must be done in linear sRGB space, however many SVG viewers 64 | do not respect that directive (e.g. most browsers).}} *) 65 | -------------------------------------------------------------------------------- /test/attic_path.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2013 The vg programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | (* This is used to be in Vg.P, removing it for now. The removal shows 7 | that this could be provided by a third party library. The only 8 | Private function is used is the elliptical arc parametrisation 9 | Vg.Vgr.Private.p.earc_params. *) 10 | 11 | open Gg 12 | open Vg 13 | 14 | module P : sig 15 | 16 | type linear_fold = [ `Sub of p2 | `Line of p2 | `Close ] 17 | (** The type for linear folds. *) 18 | 19 | val linear_fold : ?tol:float -> ('a -> linear_fold -> 'a) -> 'a -> path -> 'a 20 | (** [linear_fold tol f acc p] approximates the subpaths of [p] by a 21 | sequence of line segments and applies [f] to those with an 22 | accumulator. Subpaths are traversed in the order they were 23 | specified, always start with a [`Sub], but may not be 24 | [`Close]d. The maximal distance between the original path and 25 | the linear approximation does not exceed [tol] (defaults to 26 | [1e-3]). *) 27 | 28 | type sampler = [ `Sub of p2 | `Sample of p2 | `Close ] 29 | (** The type for path samplers. *) 30 | 31 | val sample : ?tol:float -> float -> ('a -> sampler -> 'a) -> 'a -> path -> 'a 32 | (** [sample tol dt f acc p], samples the subpaths of [p] at every 33 | distance [dt] on the curve and applies [f] to those with an 34 | accumulator. Subpaths are traversed in the order they were 35 | specified, always start with a [`Sub], followed by 36 | [`Sample]s at every distance [dt] along the curve. If the subpath 37 | is closed [`Close] is called aswell. [tol] has the same meaning 38 | as in {!linear_fold}. *) 39 | 40 | val bounds : ?ctrl:bool -> path -> box2 41 | (** [bounds ctrl p] is an axis-aligned rectangle containing [p]. If 42 | [ctrl] is [true] (defaults to [false]) control points are also 43 | included in the rectangle. Returns {!Gg.Box2.empty} if the path 44 | is [empty]. 45 | 46 | {b Warning.} This function computes the bounds of the ideal 47 | path (without width). Path {!outline}s areas will exceed these 48 | bounds. *) 49 | end = struct 50 | 51 | (* linear_{qcurve,ccurve,earc} functions are not t.r. but the recursion 52 | should converge stop rapidly. *) 53 | 54 | type linear_fold = [ `Sub of p2 | `Line of p2 | `Close ] 55 | type sampler = [ `Sub of p2 | `Sample of p2 | `Close ] 56 | 57 | let linear_qcurve tol line acc p0 p1 p2 = 58 | let tol = 16. *. tol *. tol in 59 | let rec loop tol line acc p0 p1 p2 = 60 | let is_flat = (* adapted from the cubic case. *) 61 | let ux = 2. *. P2.x p1 -. P2.x p0 -. P2.x p2 in 62 | let uy = 2. *. P2.y p1 -. P2.y p0 -. P2.y p2 in 63 | let ux = ux *. ux in 64 | let uy = uy *. uy in 65 | ux +. uy <= tol 66 | in 67 | if is_flat then line acc p2 else 68 | let p01 = P2.mid p0 p1 in 69 | let p12 = P2.mid p1 p2 in 70 | let p012 = P2.mid p01 p12 in 71 | loop tol line (loop tol line acc p0 p01 p012) p012 p12 p2 72 | in 73 | loop tol line acc p0 p1 p2 74 | 75 | let rec linear_ccurve tol line acc p0 p1 p2 p3 = 76 | let tol = 16. *. tol *. tol in 77 | let rec loop tol line acc p0 p1 p2 p3 = 78 | let is_flat = (* cf. Kaspar Fischer according to R. Willocks. *) 79 | let ux = 3. *. P2.x p1 -. 2. *. P2.x p0 -. P2.x p3 in 80 | let uy = 3. *. P2.y p1 -. 2. *. P2.y p0 -. P2.y p3 in 81 | let ux = ux *. ux in 82 | let uy = uy *. uy in 83 | let vx = 3. *. P2.x p2 -. 2. *. P2.x p3 -. P2.x p0 in 84 | let vy = 3. *. P2.y p2 -. 2. *. P2.y p3 -. P2.y p0 in 85 | let vx = vx *. vx in 86 | let vy = vy *. vy in 87 | let mx = if ux > vx then ux else vx in 88 | let my = if uy > vy then uy else vy in 89 | mx +. my <= tol 90 | in 91 | if is_flat then line acc p3 else 92 | let p01 = P2.mid p0 p1 in 93 | let p12 = P2.mid p1 p2 in 94 | let p23 = P2.mid p2 p3 in 95 | let p012 = P2.mid p01 p12 in 96 | let p123 = P2.mid p12 p23 in 97 | let p0123 = P2.mid p012 p123 in 98 | loop tol line (loop tol line acc p0 p01 p012 p0123) p0123 p123 p23 p3 99 | in 100 | loop tol line acc p0 p1 p2 p3 101 | 102 | let linear_earc tol line acc p0 large cw a r p1 = 103 | match Vgr.Private.P.earc_params p0 large cw a r p1 with 104 | | None -> line acc p1 105 | | Some (c, m, t0, t1) -> 106 | let tol2 = tol *. tol in 107 | let rec loop tol line acc p0 t0 p1 t1 = 108 | let t = (t0 +. t1) /. 2. in 109 | let b = V2.add c (V2.ltr m (V2.v (cos t) (sin t))) in 110 | let is_flat = (* cf. Drawing elliptic... L. Maisonbe *) 111 | let x0 = V2.x p0 in 112 | let y0 = V2.y p0 in 113 | let px = V2.y p1 -. y0 in 114 | let py = -. (V2.x p1 -. x0) in 115 | let vx = V2.x b -. x0 in 116 | let vy = V2.y b -. y0 in 117 | let dot = (px *. vx +. py *. vy) in 118 | let d = dot *. dot /. (vx *. vx +. vy *. vy) in 119 | d <= tol 120 | in 121 | if is_flat then line acc p1 else 122 | loop tol line (loop tol line acc p0 t0 b t) b t p1 t1 123 | in 124 | loop tol2 line acc p0 t0 p1 t1 125 | 126 | let linear_fold ?(tol = 1e-3) f acc p = 127 | let line acc pt = f acc (`Line pt) in 128 | let linear (acc, last) = function 129 | | `Sub pt -> f acc (`Sub pt), pt 130 | | `Line pt -> line acc pt, pt 131 | | `Qcurve (c, pt) -> linear_qcurve tol line acc last c pt, pt 132 | | `Ccurve (c, c', pt) -> linear_ccurve tol line acc last c c' pt, pt 133 | | `Earc (l, cw, a, r, pt) -> linear_earc tol line acc last l cw a r pt, pt 134 | | `Close -> f acc `Close, (* ignored, `Sub or end follows *) last 135 | in 136 | fst (P.fold linear (acc, P2.o) p) 137 | 138 | let sample ?tol period f acc p = 139 | let sample (acc, last, residual) = function 140 | | `Sub pt -> f acc (`Sub pt), pt, 0. 141 | | `Line pt -> 142 | let seg_len = V2.(norm (pt - last)) in 143 | let first_pt = period -. residual in 144 | let to_walk = seg_len -. first_pt in 145 | let pt_count = int_of_float (to_walk /. period) in 146 | let residual' = to_walk -. (float pt_count) *. period in 147 | let acc = ref acc in 148 | for i = 0 to pt_count do 149 | let t = (first_pt +. (float i) *. period) /. seg_len in 150 | acc := f !acc (`Sample (V2.mix last pt t)) 151 | done; 152 | (!acc, pt, residual') 153 | | `Close -> f acc `Close, (* ignored `Sub or end follows *) last, 0. 154 | in 155 | let acc, _, _ = linear_fold ?tol sample (acc, P2.o, 0.) p in 156 | acc 157 | 158 | (* Needs fixing in certain cases, see comments. *) 159 | let bounds ?(ctrl = false) = function 160 | | [] -> Box2.empty 161 | | p -> 162 | let xmin = ref max_float in 163 | let ymin = ref max_float in 164 | let xmax = ref ~-.max_float in 165 | let ymax = ref ~-.max_float in 166 | let update pt = 167 | let x = P2.x pt in 168 | let y = P2.y pt in 169 | if x < !xmin then xmin := x; 170 | if x > !xmax then xmax := x; 171 | if y < !ymin then ymin := y; 172 | if y > !ymax then ymax := y 173 | in 174 | let rec seg_ctrl = function 175 | | `Sub pt :: l -> update pt; seg_ctrl l 176 | | `Line pt :: l -> update pt; seg_ctrl l 177 | | `Qcurve (c, pt) :: l -> update c; update pt; seg_ctrl l 178 | | `Ccurve (c, c', pt) :: l -> update c; update c'; update pt; seg_ctrl l 179 | | `Earc (large, cw, angle, radii, pt) :: l -> 180 | let last = last_pt l in 181 | begin match earc_params last large cw angle radii pt with 182 | | None -> update pt; seg_ctrl l 183 | | Some (c, m, a1, a2) -> 184 | (* Wrong in general. There are many cases to consider. 185 | Depending on a1 - a2 < pi or crosses the ellipses axes. 186 | Do proper development on paper. *) 187 | let t = (a1 +. a2) /. 2. in 188 | let b = V2.add c (V2.ltr m (V2.v (cos t) (sin t))) in 189 | update b; update pt; seg_ctrl l 190 | end 191 | | `Close :: l -> seg_ctrl l 192 | | [] -> () 193 | in 194 | let rec seg = function 195 | | `Sub pt :: l -> update pt; seg l 196 | | `Line pt :: l -> update pt; seg l 197 | | `Qcurve (c, pt) :: l -> 198 | (* Wrong, compute bound *) update c; update pt; seg l 199 | | `Ccurve (c, c', pt) :: l -> 200 | let last = last_pt l in 201 | let update_z dim = (* Kallay, computing tight bounds *) 202 | let fuzz = 1e-12 in 203 | let solve a b c f = 204 | let d = b *. b -. a *. c in 205 | if (d <= 0.) then () else 206 | begin 207 | let d = sqrt d in 208 | let b = -. b in 209 | let b = if (b > 0.) then b +. d else b -. d in 210 | if (b *. a > 0.) then f (b /. a); 211 | let a = d *. c in 212 | let b = c *. c *. fuzz in 213 | if (a > b || -. a < -. b) then f (c /. d); 214 | end 215 | in 216 | let a = dim last in 217 | let b = dim c in 218 | let cc = dim c' in 219 | let d = dim pt in 220 | if (a < b && b < d) && (a < cc && cc < d) then () else 221 | let a = b -. a in 222 | let b = cc -. b in 223 | let cc = d -. cc in 224 | let fa = abs_float a in 225 | let fb = abs_float b *. fuzz in 226 | let fc = abs_float cc in 227 | if (fa < fb && fc < fb) then () else 228 | if (fa > fc) then 229 | let upd s = 230 | update (casteljau last c c' pt (1.0 /. (1.0 +. s))) 231 | in 232 | solve a b cc upd; 233 | else 234 | let upd s = update (casteljau last c c' pt (s /. (1.0 +. s))) in 235 | solve cc b a upd 236 | in 237 | update_z V2.x; update_z V2.y; update pt; seg l 238 | | `Earc (large, cw, angle, radii, pt) :: l -> 239 | let last = last_pt l in 240 | begin match earc_params last large cw angle radii pt with 241 | | None -> update pt; seg l 242 | | Some (c, m, a1, a2) -> 243 | (* Wrong in general, see above. *) 244 | let t = (a1 +. a2) /. 2. in 245 | let b = V2.add c (V2.ltr m (V2.v (cos t) (sin t))) in 246 | update b; update pt; seg l 247 | end 248 | | `Close :: l -> seg l 249 | | [] -> () 250 | in 251 | if ctrl then seg_ctrl p else seg p; 252 | Box2.v (P2.v !xmin !ymin) (Size2.v (!xmax -. !xmin) (!ymax -. !ymin)) 253 | 254 | end 255 | -------------------------------------------------------------------------------- /test/db/alphas.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2013 The vg programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | open Gg 7 | open Vg 8 | ;; 9 | 10 | (** Test images for alpha blending. *) 11 | 12 | Db.image "alpha-spots" __POS__ ~author:Db.dbuenzli 13 | ~title:"Alpha spots" 14 | ~tags:["alpha"] 15 | ~note:"Spots with 0.75 alpha composed in various order. Left to right, 16 | top to bottom, back most color first: rgb, rbg, grb, gbr, brg, bgr." 17 | ~size:(Size2.v 70. 100.) 18 | ~view:(Box2.v P2.o (Size2.v 0.7 1.0)) 19 | begin fun _ -> 20 | let a = Float.pi_div_2 in 21 | let da = Float.two_pi /. 3. in 22 | let dotp = P.empty |> P.circle P2.o 0.08 in 23 | let dot c da = I.const c |> I.cut dotp |> I.move (V2.polar 0.05 (a +. da)) in 24 | let r = dot (Color.v_srgb 0.608 0.067 0.118 ~a:0.75) da in 25 | let g = dot (Color.v_srgb 0.314 0.784 0.471 ~a:0.75) 0. in 26 | let b = dot (Color.v_srgb 0.000 0.439 0.722 ~a:0.75) (-. da) in 27 | let triplet a b c = a |> I.blend b |> I.blend c in 28 | let triplet_row y a b c = 29 | let fst = triplet a b c |> I.move (P2.v 0.2 y) in 30 | let snd = triplet a c b |> I.move (P2.v 0.5 y) in 31 | fst |> I.blend snd 32 | in 33 | (triplet_row 0.8 r g b) |> I.blend 34 | (triplet_row 0.5 g r b) |> I.blend 35 | (triplet_row 0.2 b r g) 36 | end 37 | -------------------------------------------------------------------------------- /test/db/arrowhead.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2013 The vg programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | open Gg 7 | open Vg 8 | ;; 9 | 10 | (** Sierpiński Arrowhead curve 11 | http://mathworld.wolfram.com/SierpinskiArrowheadCurve.html *) 12 | 13 | Db.image "arrowhead" __POS__ ~author:Db.dbuenzli 14 | ~title:"Sierpiński Arrowhead curve levels 0-9" 15 | ~tags:["fractal"; "image"] 16 | ~note:(Printf.sprintf "Last curve made of %g segments" (3. ** (float 9))) 17 | ~size:(Size2.v 120. 255.) 18 | ~view:(Box2.v P2.o (Size2.v 2. 4.25)) 19 | begin fun _ -> 20 | let arrowhead_path i len = 21 | let angle = Float.pi /. 3. in 22 | let rec loop i len sign turn p = 23 | if i = 0 then p |> P.line ~rel:true V2.(polar len turn) else 24 | p |> 25 | loop (i - 1) (len /. 2.) (-. sign) (turn +. sign *. angle) |> 26 | loop (i - 1) (len /. 2.) sign turn |> 27 | loop (i - 1) (len /. 2.) (-. sign) (turn -. sign *. angle) 28 | in 29 | P.empty |> loop i len 1. 0. 30 | in 31 | let area = `O { P.o with P.width = 0.005 } in 32 | let gray = I.const (Color.gray 0.2) in 33 | let acc = ref I.void in 34 | for i = 0 to 9 do 35 | let x = float (i mod 2) +. 0.1 in 36 | let y = 0.85 *. float (i / 2) +. 0.1 in 37 | acc := 38 | gray |> I.cut ~area (arrowhead_path i 0.8) |> I.move (V2.v x y) |> 39 | I.blend !acc 40 | done; 41 | !acc 42 | end; 43 | -------------------------------------------------------------------------------- /test/db/colors.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2013 The vg programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | open Gg 7 | open Vg 8 | ;; 9 | 10 | (** Test images for colors. *) 11 | 12 | Db.image "color-ramps" __POS__ ~author:Db.dbuenzli 13 | ~title:"Primary and grayscale ramps" 14 | ~tags:["color"] 15 | ~note:"From 0 to 1 by 0.1 increments in sRGB space. From right to left \ 16 | top to bottom, red, green, blue, gray." 17 | ~size:(Size2.v 100. 100.) 18 | ~view:(Box2.v P2.o (Size2.v 2.2 2.2)) 19 | begin fun _ -> 20 | let levels = [ 0.0; 0.1; 0.2; 0.3; 0.4; 0.5; 0.6; 0.7; 0.8; 0.9; 1.0 ] in 21 | let sq = P.empty |> P.rect (Box2.v P2.o (Size2.v 1.1 1.1)) in 22 | let bars color = 23 | let bar l = I.const (color l) |> I.cut sq |> I.move (P2.v l 0.) in 24 | let add_bar acc l = acc |> I.blend (bar l) in 25 | List.fold_left add_bar I.void levels 26 | in 27 | (bars (fun l -> Color.v_srgb l 0. 0.) |> I.move (P2.v 0.0 1.1)) |> I.blend 28 | (bars (fun l -> Color.v_srgb 0. l 0.) |> I.move (P2.v 1.1 1.1)) |> I.blend 29 | (bars (fun l -> Color.v_srgb 0. 0. l) |> I.move (P2.v 0.0 0.0)) |> I.blend 30 | (bars (fun l -> Color.v_srgb l l l) |> I.move (P2.v 1.1 0.0)) 31 | end 32 | -------------------------------------------------------------------------------- /test/db/db.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2013 The vg programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | open Gg;; 7 | open Vg;; 8 | 9 | let str = Printf.sprintf 10 | let err_id id = str "An image with id `%s' already exists" id 11 | 12 | type author = string * string 13 | type image = 14 | { id : string; 15 | loc : string * int; 16 | title : string; 17 | author : author; 18 | tags : string list; 19 | note : string option; 20 | size : Gg.size2; 21 | view : Gg.box2; 22 | image : Gg.box2 -> Vg.image; } 23 | 24 | let images = Hashtbl.create 537 25 | let image id loc ~title ~author ?(tags = []) ?note ~size ~view image = 26 | let file, line, _, _ = loc in 27 | let file = Filename.basename file in 28 | let id = String.lowercase_ascii id in 29 | try ignore (Hashtbl.find images id); invalid_arg (err_id id) with 30 | | Not_found -> 31 | Hashtbl.add images id 32 | { id; loc = file, line; author; title; note; tags; size; view; image; } 33 | 34 | let mem id = Hashtbl.mem images id 35 | let find id = try Some (Hashtbl.find images id) with Not_found -> None 36 | let prefixed s p = 37 | let ls = String.length s in 38 | let lp = String.length p in 39 | if lp > ls then false else 40 | try 41 | for i = 0 to lp - 1 do if s.[i] <> p.[i] then raise Exit; done; 42 | true 43 | with Exit -> false 44 | 45 | let search ?(ids = []) ?(prefixes = []) ?(tags = []) () = 46 | let matches i = 47 | List.mem i.id ids || List.exists (prefixed i.id) prefixes || 48 | List.exists (fun t -> List.mem t tags) i.tags 49 | in 50 | let select _ i acc = if matches i then i :: acc else acc in 51 | let compare i i' = compare i.id i'.id in 52 | List.sort compare (Hashtbl.fold select images []) 53 | 54 | let all () = search ~prefixes:[""] () 55 | 56 | let indexes () = 57 | let add _ i (ids, tags) = 58 | let ids = i.id :: ids in 59 | let add_tag tags t = if List.mem t tags then tags else t :: tags in 60 | let tags = List.fold_left add_tag tags i.tags in 61 | ids, tags 62 | in 63 | let ids, tags = Hashtbl.fold add images ([],[]) in 64 | List.sort compare ids, List.sort compare tags 65 | 66 | let xmp ~create_date ~creator_tool i = 67 | Vgr.xmp ~title:i.title ~authors:[fst i.author] ~subjects:i.tags 68 | ?description:i.note ~creator_tool ~create_date () 69 | 70 | let renderable i = i.size, i.view, i.image i.view 71 | 72 | (* Authors *) 73 | 74 | let dbuenzli = "Daniel Bünzli", "http://erratique.ch" 75 | -------------------------------------------------------------------------------- /test/db/db.mli: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2013 The vg programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | (** Image database. *) 7 | 8 | (** {1 Images} *) 9 | 10 | type author = string * string 11 | (** The type for authors. Author name and link. *) 12 | 13 | type image = 14 | { id : string; (** unique image identifier. *) 15 | loc : string * int; (** File and line. *) 16 | title : string; (** image title. *) 17 | author : author; (** image author. *) 18 | tags : string list; (** descriptive tag list. *) 19 | note : string option; (** note about the image. *) 20 | size : Gg.size2; (** render surface size. *) 21 | view : Gg.box2; (** image view rectangle. *) 22 | image : Gg.box2 -> Vg.image; } (** image definition, arg is [view]. *) 23 | (** The type for database images. *) 24 | 25 | 26 | val image : 27 | string -> string * int * int * int -> title:string -> 28 | author:author -> ?tags:string list -> ?note:string -> 29 | size:Gg.size2 -> view:Gg.box2 -> (Gg.box2 -> Vg.image) -> unit 30 | (** [image id authors title subject note tags meta size view fimg] 31 | adds an image to the database. *) 32 | 33 | val all : unit -> image list 34 | (** [all ()] is the list of all images in the db lexicographically 35 | sorted by id. *) 36 | 37 | val mem : string -> bool 38 | (** [mem id] is [true] if there an image with id [id]. *) 39 | 40 | val find : string -> image option 41 | (** [find id] is the image with id [id], if any. *) 42 | 43 | val search : ?ids:string list -> ?prefixes:string list -> ?tags:string list -> 44 | unit -> image list 45 | (** [search ids prefixes tags ()] is a list of images lexicographically 46 | sorted by id that satisfy at least one of these conditions: 47 | {ul 48 | {- The image id is in [ids].} 49 | {- The image id is prefixed by an element of [prefixes].} 50 | {- The image has a tag in [tags].}} *) 51 | 52 | val indexes : unit -> string list * string list 53 | (** [indexes ()] is the lexicographically sorted lists of ids and 54 | tags present in the database. *) 55 | 56 | val xmp : create_date:float -> creator_tool:string -> image -> string 57 | (** [xmp create_date creator_tool i] is an XMP metadata packet for [i] *) 58 | 59 | val renderable : image -> Vg.Vgr.renderable 60 | (** [renderable i] is a renderable for [i]. *) 61 | 62 | (** {1 Authors} 63 | 64 | Authors used in many files. *) 65 | 66 | val dbuenzli : author 67 | -------------------------------------------------------------------------------- /test/db/db_contents.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2013 The vg programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | (* Renderer independent images *) 7 | 8 | include Paths 9 | include Colors 10 | include Alphas 11 | include Gradients 12 | include Uncut 13 | include Npcut 14 | include Glyphs 15 | include Glyphs_pdf 16 | include Graph 17 | include Escapes 18 | 19 | include Arrowhead 20 | include Doc 21 | include Illusions 22 | include Rmark 23 | -------------------------------------------------------------------------------- /test/db/doc.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2013 The vg programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | open Gg 7 | open Vg 8 | ;; 9 | 10 | (** Images for the documentation. *) 11 | 12 | Db.image "doc-gray-square" __POS__ ~author:Db.dbuenzli 13 | ~title:"Unit square area in gray" 14 | ~tags:["doc";] 15 | ~size:(Size2.v 30. 30.) 16 | ~view:Box2.unit 17 | ~note:"Gray indeed." 18 | begin fun _ -> 19 | I.const (Color.gray 0.5) 20 | end; 21 | 22 | Db.image "doc-gray-circle" __POS__ ~author:Db.dbuenzli 23 | ~title:"Gray circle centered in the unit square" 24 | ~tags:["doc";] 25 | ~size:(Size2.v 30. 30.) 26 | ~view:Box2.unit 27 | ~note:"Indeed, gray circle." 28 | begin fun _ -> 29 | let circle = P.empty |> P.circle (P2.v 0.5 0.5) 0.4 in 30 | let gray = I.const (Color.gray 0.5) in 31 | let gray_circle = I.cut circle gray in 32 | gray_circle 33 | end; 34 | 35 | Db.image "doc-circle-outline" __POS__ ~author:Db.dbuenzli 36 | ~title:"Blue circle outline centered in the unit square" 37 | ~tags:["doc";] 38 | ~size:(Size2.v 30. 30.) 39 | ~view:Box2.unit 40 | begin fun _ -> 41 | let circle = P.empty |> P.circle (P2.v 0.5 0.5) 0.4 in 42 | let circle_outline = 43 | let area = `O { P.o with P.width = 0.04 } in 44 | let blue = I.const (Color.v_srgb 0.000 0.439 0.722) in 45 | I.cut ~area circle blue 46 | in 47 | circle_outline 48 | end; 49 | 50 | Db.image "doc-dot" __POS__ ~author:Db.dbuenzli 51 | ~title:"Outlined gray circle centered in the unit square" 52 | ~tags:["doc";] 53 | ~size:(Size2.v 30. 30.) 54 | ~view:Box2.unit 55 | begin fun _ -> 56 | let circle = P.empty |> P.circle (P2.v 0.5 0.5) 0.4 in 57 | let area = `O { P.o with P.width = 0.04 } in 58 | let gray = I.const (Color.gray 0.65) in 59 | let blue = I.const (Color.v_srgb 0.000 0.439 0.722) in 60 | let gray_circle = I.cut circle gray in 61 | let circle_outline = I.cut ~area circle blue in 62 | let dot = I.blend circle_outline gray_circle in 63 | dot 64 | end; 65 | 66 | Db.image "doc-scatter-plot" __POS__ ~author:Db.dbuenzli 67 | ~title:"Scatter plot" 68 | ~tags:["doc"] 69 | ~note:"800 points with coordinates on independent normal distributions." 70 | ~size:(Size2.v 40. 40.) 71 | ~view:Box2.unit 72 | begin fun _ -> 73 | let scatter_plot pts pt_width = 74 | let dot = 75 | let circle = P.empty |> P.circle P2.o (0.5 *. pt_width) in 76 | I.const (Color.v_srgb 0.000 0.439 0.722) |> I.cut circle 77 | in 78 | let mark pt = dot |> I.move pt in 79 | let blend_mark acc pt = acc |> I.blend (mark pt) in 80 | List.fold_left blend_mark I.void pts 81 | in 82 | let normal_pts count = 83 | let s = Random.State.make [|18278|] in 84 | let rand = Float.srandom s in 85 | let normal_pt () = (* Box-Muller transform. *) 86 | let u1 = rand ~len:1.0 () in 87 | let u2 = rand ~len:1.0 () in 88 | let z0 = sqrt (-. 2. *. log u1) *. cos (Float.two_pi *. u2) in 89 | let z1 = sqrt (-. 2. *. log u1) *. sin (Float.two_pi *. u2) in 90 | P2.v z0 z1 91 | in 92 | let acc = ref [] in 93 | for i = 1 to count do 94 | acc := V2.((P2.v 0.5 0.5) + 0.125 * normal_pt ()) :: !acc 95 | done; 96 | !acc 97 | in 98 | scatter_plot (normal_pts 800) 0.01 99 | end; 100 | 101 | Db.image "doc-subpaths" __POS__ ~author:Db.dbuenzli 102 | ~title:"Subpaths" 103 | ~tags:["doc"] 104 | ~note:"Illustrates subpaths construction." 105 | ~size:(Size2.v 30. 30.) 106 | ~view:Box2.unit 107 | begin fun _ -> 108 | let p = 109 | let rel = true in 110 | P.empty |> 111 | P.sub (P2.v 0.1 0.5) |> 112 | P.line (P2.v 0.3 0.5) |> 113 | P.qcurve ~rel (P2.v 0.2 0.5) (P2.v 0.2 0.0) |> 114 | P.ccurve ~rel (P2.v 0.0 (-. 0.5)) (P2.v 0.1 (-. 0.5)) (P2.v 0.3 0.0) |> 115 | P.earc ~rel (Size2.v 0.1 0.2) (P2.v 0.15 0.0) |> 116 | P.sub (P2.v 0.18 0.26) |> 117 | P.qcurve ~rel (P2.v (0.01) (-0.1)) (P2.v 0.1 (-. 0.05)) |> 118 | P.close |> 119 | P.sub (P2.v 0.65 0.8) |> 120 | P.line ~rel (P2.v 0.1 (-. 0.05)) 121 | in 122 | let area = `O { P.o with P.width = 0.01 } in 123 | I.const (Color.v_srgb 0.000 0.439 0.722) |> I.cut ~area p 124 | end 125 | ;; 126 | 127 | let directed_pentagram arrow area r = 128 | let arrow p0 p1 = (* arrow at the beginning of the line p0p1. *) 129 | let l = V2.(p1 - p0) in 130 | let angle = V2.angle l in 131 | let loc = V2.(p0 + 0.2 * l) in 132 | I.const Color.black |> I.cut arrow |> I.rot angle |> I.move loc 133 | in 134 | let a = Float.pi_div_2 in (* points of the pentagram. *) 135 | let da = Float.two_pi /. 5. in 136 | let p0 = V2.polar r a in 137 | let p1 = V2.polar r (a -. 2. *. da) in 138 | let p2 = V2.polar r (a +. da) in 139 | let p3 = V2.polar r (a -. da) in 140 | let p4 = V2.polar r (a +. 2. *. da) in 141 | let pentagram = (* http://mathworld.wolfram.com/StarPolygon.html *) 142 | P.(empty |> sub p0 |> line p1 |> line p2 |> line p3 |> line p4 |> close) 143 | in 144 | let lines = `O { P.o with P.width = 0.01 } in 145 | I.const (Color.gray 0.8) |> I.cut ~area pentagram |> 146 | I.blend (I.const Color.black |> I.cut ~area:lines pentagram) |> 147 | I.blend (arrow p0 p1) |> I.blend (arrow p1 p2) |> I.blend (arrow p2 p3) |> 148 | I.blend (arrow p3 p4) |> I.blend (arrow p4 p0) 149 | 150 | let directed_annulus arrow ~rev area r = 151 | let arrow ?(rev = false) r a = (* arrow at polar coordinate (r, a). *) 152 | let angle = a +. (if rev then -. Float.pi_div_2 else Float.pi_div_2) in 153 | let loc = V2.polar r a in 154 | I.const Color.black |> I.cut arrow |> I.rot angle |> I.move loc 155 | in 156 | let arrows ?(rev = false) r = 157 | arrow ~rev r 0. |> 158 | I.blend (arrow ~rev r (Float.pi_div_2)) |> 159 | I.blend (arrow ~rev r (2. *. Float.pi_div_2)) |> 160 | I.blend (arrow ~rev r (-. Float.pi_div_2)) 161 | in 162 | let circle ?(rev = false) r = 163 | let c = P.empty |> P.circle P2.o r in 164 | if rev then (* flip *) P.tr (M3.scale2 (V2.v (- 1.) 1.)) c else c 165 | in 166 | let outer = r in 167 | let inner = r *. 0.6 in 168 | let annulus = P.append (circle outer) (circle ~rev inner) in 169 | let outline = `O { P.o with P.width = 0.01 } in 170 | I.const (Color.gray 0.8) |> I.cut ~area annulus |> 171 | I.blend (I.const Color.black |> I.cut ~area:outline annulus) |> 172 | I.blend (arrows outer) |> 173 | I.blend (arrows ~rev inner) 174 | 175 | let area_rule_examples area = 176 | let arrow = 177 | let a = Float.two_pi /. 3. in 178 | let pt a = V2.polar 0.032 a in 179 | P.(empty |> sub (pt 0.) |> line (pt (-. a)) |> line (pt a) |> close) 180 | in 181 | let pentagram = directed_pentagram arrow area 0.4 in 182 | let annulus = directed_annulus arrow ~rev:false area 0.3 in 183 | let annulus_r = directed_annulus arrow ~rev:true area 0.3 in 184 | let y = 0.46 in 185 | I.const Color.white |> 186 | I.blend pentagram |> I.move (V2.v 0.5 y) |> 187 | I.blend (annulus |> I.move (V2.v 1.5 y)) |> 188 | I.blend (annulus_r |> I.move (V2.v 2.5 y)) 189 | ;; 190 | 191 | Db.image "doc-anz" __POS__ ~author:Db.dbuenzli 192 | ~title:"Non-zero winding area rule" 193 | ~tags:["doc"] 194 | ~note:"Illustrates the non-zero winding area rule." 195 | ~size:(Size2.v 90. 30.) 196 | ~view:(Box2.v P2.o (Size2.v 3.0 1.0)) 197 | begin fun _ -> area_rule_examples `Anz end; 198 | 199 | Db.image "doc-aeo" __POS__ ~author:Db.dbuenzli 200 | ~title:"Even-odd winding area rule" 201 | ~tags:["doc"] 202 | ~note:"Illustrates the even-odd winding area rule." 203 | ~size:(Size2.v 90. 30.) 204 | ~view:(Box2.v P2.o (Size2.v 3.0 1.0)) 205 | begin fun _ -> 206 | area_rule_examples `Aeo 207 | end; 208 | 209 | Db.image "doc-caps" __POS__ ~author:Db.dbuenzli 210 | ~title:"Path caps" 211 | ~tags:["doc"] 212 | ~note:"Illustrates path cap styles. From left to right: \ 213 | `Butt, `Round and `Square." 214 | ~size:(Size2.v 90. 20.) 215 | ~view:(Box2.v P2.o (Size2.v 3.0 (3.0 /. 4.5))) 216 | begin fun _ -> 217 | let gray = I.const (Color.gray 0.3) in 218 | let white = I.const Color.white in 219 | let line = P.(empty |> sub (P2.v 0.25 0.333) |> line (P2.v 0.75 0.333)) in 220 | let line x cap = 221 | let outline = I.cut ~area:(`O { P.o with P.width = 0.2; cap}) line gray in 222 | let data = I.cut ~area:(`O { P.o with P.width = 0.01 }) line white in 223 | outline |> I.blend data |> I.move (P2.v x 0.) 224 | in 225 | (line 0. `Butt) |> I.blend (line 1.0 `Round) |> I.blend (line 2. `Square) 226 | end; 227 | 228 | Db.image "doc-joins" __POS__ ~author:Db.dbuenzli 229 | ~title:"Path joins" 230 | ~tags:["doc"] 231 | ~note:"Illustrates path join styles. From left to right: \ 232 | `Miter, `Round and `Bevel." 233 | ~size:(Size2.v 90. 30.) 234 | ~view:(Box2.v P2.o (Size2.v 3.0 1.0)) 235 | begin fun _ -> 236 | let gray = I.const (Color.gray 0.3) in 237 | let white = I.const Color.white in 238 | let wedge = 239 | P.empty |> 240 | P.sub (P2.v 0.2 0.) |> P.line (P2.v 0.5 0.5) |> P.line (P2.v 0.8 0.) 241 | in 242 | let path x join = 243 | let area = (`O { P.o with P.width = 0.2; join }) in 244 | let outline = I.cut ~area wedge gray in 245 | let data = I.cut ~area:(`O { P.o with P.width = 0.01 }) wedge white in 246 | outline |> I.blend data |> I.move (P2.v x 0.2) 247 | in 248 | (path 0. `Miter) |> I.blend (path 1. `Round) |> I.blend (path 2. `Bevel) 249 | end; 250 | 251 | Db.image "doc-earcs" __POS__ ~author:Db.dbuenzli 252 | ~title:"Elliptical arcs" 253 | ~tags:["doc"; "path"] 254 | ~note:"Illustrates elliptical arc parameters. In red, elliptical arc \ 255 | from left point to right point. Top row is ~large:false. \ 256 | Left column is ~cw:false." 257 | ~size:(Size2.v 75. 45.) 258 | ~view:(Box2.v P2.o (Size2.v 7.5 4.5)) 259 | begin fun _ -> 260 | let angle = Float.rad_of_deg 0. in 261 | let r = Size2.v 1.0 0.5 in 262 | let p0 = P2.v 0. (Size2.h r) in 263 | let p1 = P2.v (Size2.w r) 0.0 in 264 | let square = P.empty |> P.rect (Box2.v_mid P2.o (Size2.v 0.1 0.1)) in 265 | let mark pt = I.const (Color.gray 0.1) |> I.cut square |> I.move pt in 266 | let ellipses = 267 | let area = `O { P.o with P.width = 0.02 } in 268 | let els = 269 | P.empty |> P.ellipse ~angle P2.o r |> P.ellipse ~angle V2.(p0 + p1) r 270 | in 271 | I.const (Color.gray 0.5) |> I.cut ~area els 272 | in 273 | let solution x y sol = 274 | ellipses |> I.blend sol |> I.blend (mark p0) |> I.blend (mark p1) |> 275 | I.move (P2.v x y) 276 | in 277 | let arc ~large ~cw = 278 | let a = P.(empty |> sub p0 |> earc ~large ~cw ~angle r p1) in 279 | I.const Color.red |> I.cut ~area:(`O { P.o with P.width = 0.02 }) a 280 | in 281 | let l, r, t, b = 1.5, 5.0, 3.0, 1.0 in 282 | (arc ~large:false ~cw:false |> solution l t) |> I.blend 283 | (arc ~large:false ~cw:true |> solution r t) |> I.blend 284 | (arc ~large:true ~cw:false |> solution l b) |> I.blend 285 | (arc ~large:true ~cw:true |> solution r b) 286 | end; 287 | -------------------------------------------------------------------------------- /test/db/escapes.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2013 The vg programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | open Gg 7 | open Vg 8 | ;; 9 | 10 | (** Test images for data escapes *) 11 | 12 | Db.image "escape-xmp" __POS__ ~author:Db.dbuenzli 13 | ~title:"XMP metadata escape & \"bla\"" 14 | ~tags:["escape"; ] 15 | ~note:"These markup \"delimiters\" should be & escaped in \ 16 | the meta data. The image is just a gray square." 17 | ~size:(Size2.v 50. 50.) 18 | ~view:Box2.unit 19 | begin fun _ -> 20 | I.const (Color.gray 0.3) |> I.cut (P.empty |> P.rect Box2.unit) 21 | end; 22 | -------------------------------------------------------------------------------- /test/db/glyphs.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2013 The vg programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | open Gg 7 | open Vg 8 | ;; 9 | 10 | (** Test images for glyphs. *) 11 | 12 | let open_sans_xbold = 13 | { Font.name = "Open Sans"; size = 1.0; weight = `W800; slant = `Normal} 14 | 15 | (* Font info for the string "Revolt!" as found in Open_sans.extra_bold. *) 16 | 17 | let glyphs = [ 53; 72; 89; 82; 79; 87; 4 ] 18 | let advances = [1386.; 1266.; 1251.; 1305.; 662.; 942.; 594.;] 19 | let u_to_em = 2048. 20 | ;; 21 | 22 | Db.image "glyph-revolt" __POS__ ~author:Db.dbuenzli 23 | ~title:"Revolt in black" 24 | ~tags:["glyph"] 25 | ~note:"Black characters “Revolt!”, approximatively centered \ 26 | in the image." 27 | ~size:(Size2.v 135. 45.) 28 | ~view:(Box2.v P2.o (Size2.v 3. 1.)) 29 | begin fun _ -> 30 | let font = { open_sans_xbold with Font.size = 0.7 } in 31 | let text = "Revolt!" in 32 | I.const Color.black |> I.cut_glyphs ~text font glyphs |> 33 | I.move (V2.v 0.23 0.25) 34 | end; 35 | 36 | Db.image "glyph-revolt-outline" __POS__ ~author:Db.dbuenzli 37 | ~title:"Revolt outline in black" 38 | ~tags:["glyph"] 39 | ~note:"Black outlined characters “Revolt!”, approximatively centered \ 40 | in the image with bevel path joins." 41 | ~size:(Size2.v 135. 45.) 42 | ~view:(Box2.v P2.o (Size2.v 3. 1.)) 43 | begin fun _ -> 44 | let font = { open_sans_xbold with Font.size = 0.7 } in 45 | let area = `O { P.o with P.width = 0.03; join = `Bevel } in 46 | let text = "Revolt!" in 47 | I.const Color.black |> I.cut_glyphs ~area ~text font glyphs |> 48 | I.move (V2.v 0.23 0.25) 49 | end; 50 | 51 | Db.image "glyph-revolt-fade" __POS__ ~author:Db.dbuenzli 52 | ~title:"Revolt from black to white" 53 | ~tags:["glyph"; "gradient" ] 54 | ~note:"Characters “Revolt!”, approximatively centered \ 55 | in the image and fading from black to white" 56 | ~size:(Size2.v 135. 45.) 57 | ~view:(Box2.v P2.o (Size2.v 3. 1.)) 58 | begin fun _ -> 59 | let font = { open_sans_xbold with Font.size = 0.7 } in 60 | let text = "Revolt!" in 61 | let stops = [0.0, Color.black; 1.0, Color.white] in 62 | I.axial stops P2.o (P2.v 3. 0.) |> I.cut_glyphs ~text font glyphs |> 63 | I.move (V2.v 0.23 0.25) 64 | end; 65 | 66 | 67 | Db.image "glyph-aspect" __POS__ ~author:Db.dbuenzli 68 | ~title:"Glyph aspect" 69 | ~tags:["glyph"] 70 | ~note:"The character should read “R”, without distortion." 71 | ~size:(Size2.v 25. 50.) 72 | ~view:(Box2.v P2.o (Size2.v 2. 1.)) 73 | begin fun _ -> 74 | let font = { open_sans_xbold with Font.size = 0.5 } in 75 | let text = "R" in 76 | let sq = P.empty |> P.rect (Box2.v (P2.v 0. 0.75) (P2.v 0.25 0.25)) in 77 | I.const Color.black |> I.cut sq |> 78 | I.blend (I.const Color.black |> I.cut_glyphs ~text font [53;]) |> 79 | I.scale (V2.v 4.0 1.0) 80 | end; 81 | 82 | Db.image "glyph-multi" __POS__ ~author:Db.dbuenzli 83 | ~title:"Multiple revolts" 84 | ~tags:["glyph"] 85 | ~note:"Rectangle filled with revolts rotated by 30°." 86 | ~size:(Size2.v 108. 135.) 87 | ~view:(Box2.v P2.o (P2.v 0.8 1.0)) 88 | begin fun view -> 89 | let font = { open_sans_xbold with Font.size = 0.025 } in 90 | let text = "Revolt!" in 91 | let angle = Float.rad_of_deg 30. in 92 | let revolt pos = 93 | I.const Color.black |> I.cut_glyphs ~text font glyphs |> 94 | I.move pos 95 | in 96 | let next max dv pt = 97 | if V2.x pt < V2.x max then Some (V2.v (V2.x pt +. V2.x dv) (V2.y pt)) else 98 | let y = V2.y pt +. V2.y dv in 99 | if y > V2.y max then None else Some (V2.v 0. y) 100 | in 101 | let max = V2.v 1.3 1.3 in 102 | let dv = V2.v 0.11 0.03 in 103 | let rec blend_revolt acc = function 104 | | None -> acc 105 | | Some pt -> blend_revolt (acc |> I.blend (revolt pt)) (next max dv pt) 106 | in 107 | let margin = 108 | let area = `O { P.o with P.width = 0.1 } in 109 | I.const Color.white |> I.cut ~area (P.empty |> P.rect view) 110 | in 111 | blend_revolt (I.const Color.white) (Some P2.o) |> I.rot angle |> 112 | I.move (P2.v 0.2 (-. sin (angle))) |> 113 | I.blend margin 114 | end; 115 | 116 | Db.image "glyph-advances" __POS__ ~author:Db.dbuenzli 117 | ~title:"Advancing revolt" 118 | ~tags:["glyph"] 119 | ~note:"First line, no advances specified. Second line advances with glyph 120 | advances, should render same as first line. Third line, funky glyph 121 | advances with up and down." 122 | ~size:(Size2.v 135. (45. *. 3.)) 123 | ~view:(Box2.v P2.o (Size2.v 3. 3.)) 124 | begin fun _ -> 125 | let fsize = 0.7 in 126 | let font = { open_sans_xbold with Font.size = fsize } in 127 | let text = "Revolt!" in 128 | let black = I.const Color.black in 129 | let ypos n = V2.v 0.23 (0.25 +. n *. 0.98) in 130 | let no_advances = I.cut_glyphs ~text font glyphs in 131 | let adv_advances = 132 | let adv a = V2.v ((a *. fsize) /. u_to_em) 0. in 133 | I.cut_glyphs ~text ~advances:(List.map adv advances) font glyphs 134 | in 135 | let funky_advances = 136 | let adv i a = 137 | V2.v ((a *. fsize) /. u_to_em) (if i mod 2 = 0 then 0.2 else -0.2) 138 | in 139 | I.cut_glyphs ~text ~advances:(List.mapi adv advances) font glyphs 140 | in 141 | black |> funky_advances |> I.move (ypos 0.) |> 142 | I.blend (black |> adv_advances |> I.move (ypos 1.)) |> 143 | I.blend (black |> no_advances |> I.move (ypos 2.)) 144 | end 145 | ;; 146 | 147 | Db.image "glyph-affiche-blocks" __POS__ ~author:Db.dbuenzli 148 | ~title:"Affiché with ligature and text to glyph correspondence" 149 | ~tags:["glyph"] 150 | ~note:"The ffi is a single glyph and the é glyph is encoded as the sequence 151 | in the text string." 152 | ~size:(Size2.v 135. 45.) 153 | ~view:(Box2.v P2.o (Size2.v 3. 1.)) 154 | begin fun _ -> 155 | let font = { open_sans_xbold with Font.size = 0.7 } in 156 | let glyphs = [ 36; 605; 70; 75; 171 ] in 157 | let text = "Affiche\xCC\x81" in 158 | let blocks = false, [(1,1); (3,1); (1,1); (1,1); (2,1)] in 159 | I.const Color.black |> I.cut_glyphs ~text ~blocks font glyphs |> 160 | I.move (V2.v 0.23 0.25) 161 | end 162 | ;; 163 | -------------------------------------------------------------------------------- /test/db/glyphs_pdf.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2013 The vg programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | open Gg;; 7 | open Vg;; 8 | 9 | (* Tests the generic PDF font resolutions. *) 10 | 11 | let supported_uchars = 12 | [ `Range (0x0000, 0x007F); `Range (0x00A0, 0x00FF); 13 | `Cp 0x20AC; `Cp 0x201A; `Cp 0x0192; `Cp 0x201E; `Cp 0x2026; `Cp 0x2020; 14 | `Cp 0x2021; `Cp 0x02C6; `Cp 0x2030; `Cp 0x0160; `Cp 0x2039; `Cp 0x0152; 15 | `Cp 0x017D; `Cp 0x2018; `Cp 0x2019; `Cp 0x201C; `Cp 0x201D; `Cp 0x2022; 16 | `Cp 0x2013; `Cp 0x2014; `Cp 0x02DC; `Cp 0x2122; `Cp 0x0161; `Cp 0x203A; 17 | `Cp 0x0153; `Cp 0x017E; `Cp 0x0178; ] 18 | 19 | let foldi_uchars f acc = 20 | let rec loop i acc = function 21 | | [] -> acc 22 | | `Cp u :: us -> loop (i + 1) (f i acc u) us 23 | | `Range (l, h) :: us -> 24 | let acc = ref acc in 25 | for u = l to h do acc := f (i + u - l) !acc u done; 26 | loop (i + h - l + 1) !acc us 27 | in 28 | loop 0 acc supported_uchars 29 | 30 | let utf8 u = 31 | let b = Buffer.create 4 in 32 | Buffer.add_utf_8_uchar b (Uchar.of_int u); Buffer.contents b 33 | 34 | let glyph_chart font = 35 | let black = I.const Color.black in 36 | let gray = I.const (Color.gray 0.75) in 37 | let cage = Box2.v (P2.v (-0.2) (-0.2)) (Size2.v 0.8 0.8) in 38 | let cage = P.empty |> P.rect cage in 39 | let area = `O { P.o with P.width = 0.01 } in 40 | let glyph_box i acc u = 41 | let y = 15. -. float (i / 16) in 42 | let x = float (i mod 16) in 43 | let glyph = 44 | I.cut_glyphs ~text:(utf8 u) font [] black |> 45 | I.blend (I.cut ~area cage gray) |> 46 | I.move (P2.v x y) 47 | in 48 | acc |> I.blend glyph 49 | in 50 | foldi_uchars glyph_box I.void |> 51 | I.move (P2.v 2. 2.) 52 | 53 | let font ?(bold = false) ?(slant = `Normal) name size = 54 | let weight = if bold then `W700 else `W400 in 55 | { Font.name = name; size; slant; weight; } 56 | 57 | let size = Size2.v 130. 130. 58 | let view = Box2.v P2.o (P2.v 19.5 19.5) 59 | let tags = [ "glyph" ] 60 | let fsize = 0.42 61 | 62 | (* Helvetica *) 63 | 64 | let helvetica = "Helvetica";; 65 | 66 | Db.image "glyph-pdf-sans" __POS__ ~author:Db.dbuenzli 67 | ~title:"Glyph chart for PDF `Sans font resolution" ~tags ~size ~view 68 | begin fun view -> glyph_chart (font helvetica fsize) end;; 69 | 70 | Db.image "glyph-pdf-sans-bf" __POS__ ~author:Db.dbuenzli 71 | ~title:"Glyphs of PDF `Sans bold font resolution" ~tags ~size ~view 72 | begin fun view -> glyph_chart (font ~bold:true helvetica fsize) end;; 73 | 74 | let slant = `Oblique;; 75 | 76 | Db.image "glyph-pdf-sans-obl" __POS__ ~author:Db.dbuenzli 77 | ~title:"Glyph chart for PDF `Sans oblique font resolution" ~tags ~size ~view 78 | begin fun view -> glyph_chart (font ~slant helvetica fsize) end;; 79 | 80 | Db.image "glyph-pdf-sans-obl-bf" __POS__ ~author:Db.dbuenzli 81 | ~title:"Glyphs of PDF `Sans oblique bold font resolution" ~tags ~size ~view 82 | begin fun view -> glyph_chart (font ~slant ~bold:true helvetica fsize) end;; 83 | 84 | (* Times *) 85 | 86 | let times = "Times";; 87 | 88 | Db.image "glyph-pdf-serif" __POS__ ~author:Db.dbuenzli 89 | ~title:"Glyph chart for PDF `Serif font resolution" ~tags ~size ~view 90 | begin fun view -> glyph_chart (font times fsize) end;; 91 | 92 | Db.image "glyph-pdf-serif-bf" __POS__ ~author:Db.dbuenzli 93 | ~title:"Glyphs of PDF `Serif bold font resolution" ~tags ~size ~view 94 | begin fun view -> glyph_chart (font ~bold:true times fsize) end;; 95 | 96 | let slant = `Italic;; 97 | 98 | Db.image "glyph-pdf-serif-obl" __POS__ ~author:Db.dbuenzli 99 | ~title:"Glyph chart for PDF `Serif italic font resolution" ~tags ~size ~view 100 | begin fun view -> glyph_chart (font ~slant times fsize) end;; 101 | 102 | Db.image "glyph-pdf-serif-obl-bf" __POS__ ~author:Db.dbuenzli 103 | ~title:"Glyphs of PDF `Serif italic bold font resolution" ~tags ~size ~view 104 | begin fun view -> glyph_chart (font ~slant ~bold:true times fsize) end;; 105 | 106 | (* Courier *) 107 | 108 | let courier = "Courier";; 109 | 110 | Db.image "glyph-pdf-fixed" __POS__ ~author:Db.dbuenzli 111 | ~title:"Glyph chart for PDF `Fixed font resolution" ~tags ~size ~view 112 | begin fun view -> glyph_chart (font courier fsize) end;; 113 | 114 | Db.image "glyph-pdf-fixed-bf" __POS__ ~author:Db.dbuenzli 115 | ~title:"Glyphs of PDF `Fixed bold font resolution" ~tags ~size ~view 116 | begin fun view -> glyph_chart (font ~bold:true courier fsize) end;; 117 | 118 | let slant = `Italic;; 119 | 120 | Db.image "glyph-pdf-fixed-obl" __POS__ ~author:Db.dbuenzli 121 | ~title:"Glyph chart for PDF `Fixed italic font resolution" ~tags ~size ~view 122 | begin fun view -> glyph_chart (font ~slant courier fsize) end;; 123 | 124 | Db.image "glyph-pdf-fixed-obl-bf" __POS__ ~author:Db.dbuenzli 125 | ~title:"Glyphs of PDF `Fixed italic bold font resolution" ~tags ~size ~view 126 | begin fun view -> glyph_chart (font ~slant ~bold:true courier fsize) end;; 127 | -------------------------------------------------------------------------------- /test/db/gradients.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2013 The vg programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | open Gg 7 | open Vg 8 | ;; 9 | 10 | (** Test images for gradients. *) 11 | 12 | Db.image "gradient-axial" __POS__ ~author:Db.dbuenzli 13 | ~title:"Black to red, red to white, axial gradient" 14 | ~tags:["gradient"] 15 | ~size:(Size2.v 60. 20.) 16 | ~view:(Box2.v P2.o (Size2.v 2. 1.)) 17 | begin fun _ -> 18 | let r = P.empty |> P.rect (Box2.v P2.o (Size2.v 2. 1.)) in 19 | let stops = [0.0, Color.black; 0.5, Color.red; 1.0, Color.white] in 20 | I.cut r (I.axial stops P2.o (P2.v 2. 0.)) 21 | end; 22 | 23 | Db.image "gradient-radial" __POS__ ~author:Db.dbuenzli 24 | ~title:"White to red, red to black, radial gradients" 25 | ~tags:["gradient"] 26 | ~note:"Focus is clockwise from top left: at the center, at 45° half way to \ 27 | the circle edge, 45° just inside the circle, 120° half way to the \ 28 | circle edge." 29 | ~size:(Size2.v 60. 60.) 30 | ~view:(Box2.v P2.o (Size2.v 2. 2.)) 31 | begin fun _ -> 32 | let radial x y f = 33 | let r = P.empty |> P.rect (Box2.v P2.o (Size2.v 1. 1.)) in 34 | let stops = [0.0, Color.white; 0.5, Color.red; 1.0, Color.black] in 35 | let c = P2.v 0.5 0.5 in 36 | I.cut r (I.radial stops ~f c 0.5) |> I.move (P2.v x y) 37 | in 38 | let d45 = Float.pi_div_4 in 39 | let d120 = 2. *. Float.pi /. 3. in 40 | let f0 = P2.v 0.5 0.5 in 41 | let f1 = V2.(f0 + 0.25 * P2.v (cos d45) (sin d45)) in 42 | let f2 = V2.(f0 + 0.499 * P2.v (cos d45) (sin d45)) in 43 | let f3 = V2.(f0 + 0.25 * P2.v (cos d120) (sin d120)) in 44 | radial 0. 1. f0 |> 45 | I.blend (radial 1. 1. f1) |> 46 | I.blend (radial 1. 0. f2) |> 47 | I.blend (radial 0. 0. f3) 48 | end; 49 | 50 | Db.image "gradient-axial-move" __POS__ ~author:Db.dbuenzli 51 | ~title:"Move axial gradient and outline cut" 52 | ~tags:["gradient"] 53 | ~note:"Left, the circle is inscribed in the unit square and the gradient \ 54 | is black at the center. On the right a circle outline is cut but due 55 | to the parameters used the result should be the same as on the left." 56 | ~size:(Size2.v 60. 30.) 57 | ~view:(Box2.v P2.o (Size2.v 2. 1.)) 58 | begin fun _ -> 59 | let c = P2.v 0.5 0.5 in 60 | let r = 0.5 in 61 | let stops = [ 0., Color.red; 0.5, Color.black; 1.0, Color.red ] in 62 | let axial = I.axial stops (V2.v (-0.5) 0.) (V2.v 0.5 0.) in 63 | let left = 64 | let circle = P.empty |> P.circle c r in 65 | axial |> I.move c |> I.cut circle 66 | in 67 | let right = 68 | let circle' = P.empty |> P.circle c 0.25 in 69 | let area = `O { P.o with P.width = 0.5 } in 70 | axial |> I.move c |> I.cut ~area circle' |> I.move (V2.v 1.0 0.) 71 | in 72 | I.blend left right 73 | end; 74 | 75 | Db.image "gradient-radial-move" __POS__ ~author:Db.dbuenzli 76 | ~title:"Move radial gradient and outline cut" 77 | ~tags:["gradient"] 78 | ~note:"On the left the circle cut and the radial gradient are inscribed in \ 79 | the unit square. On the right a circle outline is cut but due to the \ 80 | the parameters used the result should be the same as on the left." 81 | ~size:(Size2.v 60. 30.) 82 | ~view:(Box2.v P2.o (Size2.v 2. 1.)) 83 | begin fun _ -> 84 | let c = P2.v 0.5 0.5 in 85 | let r = 0.5 in 86 | let stops = [ 0., Color.red; 1.0, Color.black ] in 87 | let radial = I.radial stops P2.o r in 88 | let left = 89 | let circle = P.empty |> P.circle c r in 90 | radial |> I.move c |> I.cut circle 91 | in 92 | let right = 93 | let circle' = P.empty |> P.circle c 0.25 in 94 | let area = `O { P.o with P.width = 0.5 } in 95 | radial |> I.move c |> I.cut ~area circle' |> I.move (V2.v 1.0 0.) 96 | in 97 | I.blend left right 98 | end; 99 | 100 | Db.image "gradient-scaling" __POS__ ~author:Db.dbuenzli 101 | ~title:"Gradients and scaled ones side-by-side" 102 | ~tags:["gradient"] 103 | ~note:"In the right column the gradient on the left is scaled by 104 | (1/2, 1/3)." 105 | ~size:(Size2.v 60. 60.) 106 | ~view:(Box2.v (P2.v ~-.0.1 ~-.0.1) (Size2.v 1.2 1.2)) 107 | begin fun _ -> 108 | let y = Color.v_srgb 1.000 0.827 0.000 in 109 | let b = Color.v_srgb 0.000 0.529 0.741 in 110 | let r = Color.v_srgb 0.769 0.008 0.200 in 111 | let stops = [ 0.0, r; 0.5, b; 1.0, y] in 112 | let axial = I.axial stops P2.o (P2.v 0.45 0.) in 113 | let radial = I.radial stops ~f:(P2.v 0.25 0.25) (P2.v 0.5 0.5) 0.5 in 114 | let scaled i = i |> I.scale (Size2.v 0.5 0.333) in 115 | let r = P.empty |> P.rect (Box2.v (P2.v 0. 0.) (Size2.v 0.45 0.45)) in 116 | let square ~at i = i |> I.cut r |> I.move at in 117 | square ~at:(P2.v 0.0 0.55) axial |> 118 | I.blend (square ~at:(P2.v 0.55 0.55) (scaled axial)) |> 119 | I.blend (square ~at:(P2.v 0.0 0.0) radial) |> 120 | I.blend (square ~at:(P2.v 0.55 0.0) (scaled radial)) 121 | end; 122 | 123 | 124 | Db.image "gradient-rgb-squares" __POS__ ~author:Db.dbuenzli 125 | ~title:"Shaded red, green and blue squares" 126 | ~tags:["gradient"] 127 | ~size:(Size2.v 50. 50.) 128 | ~view:(Box2.v P2.o (Size2.v 4. 4.)) 129 | begin fun _ -> 130 | let w = 2. in 131 | let r = Box2.v P2.o (Size2.v w w) in 132 | let p = P.empty |> P.rect r in 133 | let shade c = I.axial [0., c; 1., Color.void] V2.ox V2.oy in 134 | let sq ~at c = shade c |> I.scale (Box2.size r) |> I.cut p |> I.move at in 135 | sq ~at:P2.o Color.red |> 136 | I.blend (sq ~at:(P2.v w 0.) Color.green) |> 137 | I.blend (sq ~at:(P2.v w w) Color.blue) 138 | end 139 | -------------------------------------------------------------------------------- /test/db/graph.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2013 The vg programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | open Gg 7 | open Vg 8 | ;; 9 | 10 | Db.image "graph" __POS__ ~author:Db.dbuenzli 11 | ~title:"Graph drawing with combinators" 12 | ~tags:["graph"; "image"; ] 13 | ~size:(Size2.v 120. 60.) 14 | ~view:(Box2.v P2.o (Size2.v 120. 60.)) 15 | begin fun _ -> 16 | let r = Random.State.make [|1557|] in 17 | let rpt () = P2.v 18 | (Float.srandom ~min:6. ~len:108. r ()) 19 | (Float.srandom ~min:6. ~len:48. r ()) 20 | in 21 | let rec rpts n acc = if n = 0 then acc else rpts (n-1) (rpt ():: acc) in 22 | let ( ++ ) = I.blend in 23 | let node_shape = P.empty |> P.circle P2.o 2.0 in 24 | let node pt = 25 | let area = `O { P.o with P.width = 0.5 } in 26 | let i = 27 | (I.const (Color.gray 0.9) |> I.cut node_shape) ++ 28 | (I.const (Color.gray 0.3) |> I.cut ~area node_shape) |> 29 | I.move pt 30 | in 31 | i, pt 32 | in 33 | let nodes = List.map node (rpts 1500 []) in 34 | List.fold_left (fun acc n -> I.blend acc (fst n)) I.void nodes 35 | end; 36 | -------------------------------------------------------------------------------- /test/db/illusions.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2013 The vg programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | open Gg 7 | open Vg 8 | ;; 9 | 10 | (** Café wall illusion. 11 | http://mathworld.wolfram.com/CafeWallIllusion.html *) 12 | 13 | Db.image "cafe-wall" __POS__ ~author:Db.dbuenzli 14 | ~title:"Café Wall Illusion" 15 | ~tags:["image"; "dashes"; "illusion"] 16 | ~note:"Also known as Münsterberg illusion. The gray lines are parallel." 17 | ~size:(Size2.v 115. 65.) 18 | ~view:(Box2.v P2.o (Size2.v 2.3 1.3)) 19 | begin fun _ -> 20 | let line = P.empty |> P.line (P2.v 2. 0.) in 21 | let border = 22 | let area = `O { P.o with P.width = 0.005 } in 23 | I.const (Color.gray 0.5) |> I.cut ~area line 24 | in 25 | let bricks offset = 26 | let hwidth = 0.05 in 27 | let dashes = Some (offset, [0.2]) in 28 | let area = `O { P.o with P.width = 2. *. hwidth; dashes; } in 29 | I.const (Color.black) |> I.cut ~area line |> I.move (V2.v 0. hwidth) |> 30 | I.blend border 31 | in 32 | let blend_row acc (y, offset) = 33 | acc |> I.blend ((bricks offset) |> I.blend border |> I.move (V2.v 0. y)) 34 | in 35 | let rows = [0.0, 0.36; 0.1, 0.00; 0.2, 0.36; 0.3, 0.32; 0.4, 0.28; 36 | 0.5, 0.32; 0.6, 0.36; 0.7, 0.00; 0.8, 0.36; 0.9, 0.32; ] 37 | in 38 | I.const Color.white |> 39 | I.blend (List.fold_left blend_row I.void rows) |> 40 | I.blend (border |> I.move (V2.v 0. 1.)) |> 41 | I.move (V2.v 0.15 0.15) 42 | end; 43 | 44 | (** Pie chart illusion. 45 | Data taken from here http://en.wikipedia.org/wiki/File:Piecharts.svg *) 46 | 47 | Db.image "pie-ambiguity" __POS__ ~author:Db.dbuenzli 48 | ~title:"Pie chart ambiguity" 49 | ~tags:["image"; "illusion"] 50 | ~note:"Proportions showing that angles are hard to compare \ 51 | visually." 52 | ~size:(Size2.v 90. 138.) 53 | ~view:(Box2.v P2.o (Size2.v 1.5 2.3)) 54 | begin fun _ -> 55 | let pie_chart r colors pcts = 56 | let rv = V2.v r r in 57 | let sector (acc, start) color pct = 58 | let stop = start +. (pct /. 100.) *. Float.two_pi in 59 | let sector = 60 | P.empty |> 61 | P.line (V2.polar r start) |> P.earc rv (V2.polar r stop) |> 62 | P.line P2.o 63 | in 64 | acc |> I.blend (color |> I.cut sector), stop 65 | in 66 | fst (List.fold_left2 sector (I.void, Float.pi_div_2) colors pcts) 67 | in 68 | let bar_chart bar_size pad colors pcts = 69 | let w, h = V2.to_tuple bar_size in 70 | let font = 71 | { Font.name = "Open Sans"; slant = `Normal; weight = `W400; 72 | size = (h *. 0.015) } 73 | in 74 | let mgray = I.const (Color.gray 0.3) in 75 | let lgray = I.const (Color.gray 0.75) in 76 | let bar (acc, x) color pct = 77 | let bar = 78 | let box = Box2.v P2.o (Size2.v w ((pct /. 100.) *. h)) in 79 | color |> I.cut (P.empty |> P.rect box) 80 | in 81 | let label = 82 | let text = Printf.sprintf "%g" pct in 83 | let pos = P2.v (0.275 *. w) (-1.4 *. font.Font.size) in 84 | mgray |> I.cut_glyphs ~text font [] |> I.move pos 85 | in 86 | let x = x +. pad in 87 | acc |> I.blend (bar |> I.blend label |> I.move (V2.v x 0.)), x +. w 88 | in 89 | let bars, xmax = List.fold_left2 bar (I.void, 0.) colors pcts in 90 | let floor = 91 | let ln = P.empty |> P.sub (P2.v pad 0.) |> P.line (P2.v xmax 0.) in 92 | lgray |> I.cut ~area:(`O { P.o with P.width = h *. 0.001 }) ln 93 | in 94 | bars |> I.blend floor 95 | in 96 | let distribs = [[ 23.; 22.; 20.; 18.; 17.]; 97 | [ 20.; 20.; 19.; 21.; 20.]; 98 | [ 17.; 18.; 20.; 22.; 23.]] 99 | in 100 | let colors = (* Brewer's Set2, http://colorbrewer.org/ *) 101 | let c r g b = I.const (Color.v_srgbi r g b) in 102 | [c 102 194 165; c 252 141 98; c 141 160 203; c 231 138 195; c 166 216 84] 103 | in 104 | let bar_and_pie (acc, y) pcts = 105 | let pie = pie_chart 0.25 colors pcts in 106 | let bars = bar_chart (Size2.v 0.08 2.) 0.04 colors pcts in 107 | let bp = bars |> I.blend (pie |> I.move (V2.v 1.0 0.25)) in 108 | acc |> I.blend (bp |> I.move (V2.v 0. y)), y +. 0.75 109 | in 110 | let white = I.const Color.white in 111 | let charts = fst (List.fold_left bar_and_pie (white, 0.) distribs) in 112 | charts |> I.move (V2.v 0.125 0.15) 113 | end; 114 | -------------------------------------------------------------------------------- /test/db/npcut.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2013 The vg programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | open Gg 7 | open Vg 8 | 9 | (** Test images for non-primitive cuts *) 10 | 11 | let annulus = 12 | let circle r = P.empty |> P.circle (P2.v 0.5 0.5) r in 13 | let outer = 0.3 in 14 | let inner = outer *. 0.6 in 15 | P.append (circle outer) (circle inner) 16 | 17 | let unit_dots count dot_width = 18 | let s = Random.State.make [|1922278|] in 19 | let rand = Float.srandom s in 20 | let dot = 21 | let circle = P.empty |> P.circle P2.o (0.5 *. dot_width) in 22 | I.const Color.black |> I.cut circle 23 | in 24 | let acc = ref I.void in 25 | for i = 1 to count do 26 | let x = rand ~min:0.2 ~len:0.6 () in 27 | let y = rand ~min:0.2 ~len:0.6 () in 28 | acc := I.blend !acc (dot |> I.move (P2.v x y)) 29 | done; 30 | !acc 31 | 32 | let dotted_region area = 33 | let outline = `O { P.o with P.width = 0.001 } in 34 | I.cut ~area annulus (unit_dots 800 0.01) |> 35 | I.blend (I.cut ~area:outline annulus (I.const (Color.gray 0.75))) 36 | ;; 37 | 38 | Db.image "npcut-aeo" __POS__ ~author:Db.dbuenzli 39 | ~title:"Even-odd area, non primitive cut" 40 | ~tags:["cut"] 41 | ~note:"Ring with dots." 42 | ~size:(Size2.v 60. 60.) 43 | ~view:Box2.unit 44 | begin fun _ -> dotted_region `Aeo end; 45 | 46 | Db.image "npcut-anz" __POS__ ~author:Db.dbuenzli 47 | ~title:"Non-zero winding area, non primitive cut" 48 | ~tags:["cut"] 49 | ~note:"Circle with dots." 50 | ~size:(Size2.v 60. 60.) 51 | ~view:Box2.unit 52 | begin fun _ -> dotted_region `Anz end; 53 | -------------------------------------------------------------------------------- /test/db/open_sans.mli: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2013 The vg programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | val extra_bold : string 7 | (** [extra_bold] is the OpenType font 8 | {{:http://www.google.com/fonts/specimen/Open+Sans}Open Sans} extra bold. *) 9 | -------------------------------------------------------------------------------- /test/db/paths.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2013 The vg programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | open Gg 7 | open Vg 8 | ;; 9 | 10 | (** Test images for path areas. *) 11 | 12 | Db.image "path-sq-outline" __POS__ ~author:Db.dbuenzli 13 | ~title:"Square outline in gray" 14 | ~tags:["path"] 15 | ~note:"Line width is 0.1 as we are on the surface edge." 16 | ~size:(Size2.v 50. 50.) 17 | ~view:Box2.unit 18 | begin fun _ -> 19 | let square = P.empty |> P.rect (Box2.v P2.o (Size2.v 1. 1.)) in 20 | let area = `O { P.o with P.width = 0.2 } in 21 | I.const (Color.gray 0.3) |> I.cut ~area square 22 | end; 23 | 24 | Db.image "path-sq-outline-dashed" __POS__ ~author:Db.dbuenzli 25 | ~title:"Dashed square outline in gray" 26 | ~tags:["path"; "dashes";] 27 | ~note:"Line width is 0.1 as we are on the surface edge." 28 | ~size:(Size2.v 50. 50.) 29 | ~view:Box2.unit 30 | begin fun _ -> 31 | let square = P.empty |> P.rect (Box2.v P2.o (P2.v 1. 1.)) in 32 | let area = `O { P.o with P.width = 0.2; dashes = Some (0., [0.05]); } in 33 | I.const (Color.gray 0.3) |> I.cut ~area square 34 | end; 35 | 36 | Db.image "path-cubics" __POS__ ~author:Db.dbuenzli 37 | ~title:"Cubic paths cases" 38 | ~tags:["path"] 39 | ~note:"Geometric cases for cubic curves. Except in the bottom row, only \ 40 | the end point moves." 41 | ~size:(Size2.v 115. 105.) 42 | ~view:(Box2.v (P2.v (-0.75) (0.625)) (Size2.v 5.75 5.25)) 43 | begin fun _ -> 44 | let square = P.empty |> P.rect (Box2.v_mid P2.o (Size2.v 0.06 0.06)) in 45 | let lgray = Color.gray 0.5 |> I.const in 46 | let mgray = Color.gray 0.3 |> I.const in 47 | let dgray = Color.gray 0.1 |> I.const in 48 | let blue = Color.blue |> I.const in 49 | let ctrl_pt pt = blue |> I.cut square |> I.move pt in 50 | let end_pt pt = dgray |> I.cut square |> I.move pt in 51 | let tangent p0 p1 = 52 | let t = P.empty |> P.sub p0 |> P.line p1 in 53 | lgray |> I.cut ~area:(`O { P.o with P.width = 0.01 }) t 54 | in 55 | let cubic ~at p0 c0 c1 p1 = 56 | let curve = P.empty |> P.sub p0 |> P.ccurve c0 c1 p1 in 57 | mgray |> I.cut ~area:(`O { P.o with P.width = 0.02 }) curve |> 58 | I.blend (tangent p0 c0) |> I.blend (tangent p1 c1) |> 59 | I.blend (ctrl_pt c0) |> I.blend (ctrl_pt c1) |> 60 | I.blend (end_pt p0) |> I.blend (end_pt p1) |> 61 | I.move at 62 | in 63 | let p0 = P2.v 0.0 0.5 in 64 | let c1 = P2.v 0.3 1.5 in 65 | let c2 = P2.v 1.1 0.9 in 66 | let pa = P2.v 1.5 0.0 in 67 | let pb = P2.v (0.8) 1.8 in 68 | let pc = P2.v (-0.7) 0.7 in 69 | let pd = P2.v (-0.4) 1.2 in 70 | let b00 = cubic ~at:(P2.v 0.00 4.00) p0 c1 c2 pa in 71 | let b01 = cubic ~at:(P2.v 2.85 3.60) p0 c1 c2 pb in 72 | let b10 = cubic ~at:(P2.v 0.50 1.75) p0 c1 c2 pc in 73 | let b11 = cubic ~at:(P2.v 3.15 1.75) p0 c1 c2 pd in 74 | let p0 = P2.o in 75 | let c1 = P2.v 0.3 0.0 in 76 | let c2 = P2.v 1.2 0.0 in 77 | let p1 = P2.v 1.5 0.0 in 78 | let b20 = cubic ~at:(P2.v (-0.1) 1.25) p0 c1 c2 p1 in 79 | let c1 = P2.v (-. 0.3) 0.0 in 80 | let c2 = P2.v 1.8 0.0 in 81 | let b21 = cubic ~at:(P2.v 2.7 1.25) p0 c1 c2 p1 in 82 | b00 |> I.blend b01 |> I.blend 83 | b10 |> I.blend b11 |> I.blend 84 | b20 |> I.blend b21 85 | end; 86 | 87 | Db.image "paths-smooths" __POS__ 88 | ~author:("François Thiré", "mailto:franth2@gmail.com") 89 | ~title:"Smooth paths" 90 | ~tags:["path"] 91 | ~note:"Geometric cases for smooth paths" 92 | ~size:(Size2.v 115. 105.) 93 | ~view:(Box2.v (P2.v (-0.75) (0.625)) (Size2.v 5.75 5.25)) 94 | begin fun _ -> 95 | let square = P.empty |> P.rect (Box2.v_mid P2.o (Size2.v 0.06 0.06)) in 96 | let lgray = Color.gray 0.5 |> I.const in 97 | let mgray = Color.gray 0.3 |> I.const in 98 | let dgray = Color.gray 0.1 |> I.const in 99 | let blue = Color.blue |> I.const in 100 | let red = Color.red |> I.const in 101 | let ctrl_pt pt = blue |> I.cut square |> I.move pt in 102 | let smooth_pt pt = 103 | red |> I.cut square |> I.move pt in 104 | let end_pt pt = dgray |> I.cut square |> I.move pt in 105 | let tangent p0 p1 = 106 | let t = P.empty |> P.sub p0 |> P.line p1 in 107 | lgray |> I.cut ~area:(`O { P.o with P.width = 0.01 }) t 108 | in 109 | let t = 0.55191502449 in 110 | let smooth_cubic ?(rel=false) ~at p0 c0 c1 p1 c2 p2 = 111 | let curve = P.empty |> P.sub p0 |> 112 | P.ccurve ~rel c0 c1 p1 |> P.smooth_ccurve ~rel c2 p2 113 | in 114 | let smooth = P2.tr (M3.rot2 ~pt:p1 Float.pi) c1 in 115 | let c0 = if rel then V2.(c0 + p0) else c0 in 116 | let c1 = if rel then V2.(c1 + p0) else c1 in 117 | let p1 = if rel then V2.(p1 + p0) else p1 in 118 | let c2 = if rel then V2.(c2 + p1) else c2 in 119 | let p2 = if rel then V2.(p2 + p1) else p2 in 120 | mgray |> I.cut ~area:(`O { P.o with P.width = 0.02 }) curve |> 121 | I.blend (tangent p0 c0) |> I.blend (tangent p1 c1) |> 122 | I.blend (ctrl_pt c0) |> I.blend (ctrl_pt c1) |> 123 | I.blend (end_pt p0) |> I.blend (end_pt p1) |> 124 | I.blend (smooth_pt smooth) |> I.blend (tangent p1 smooth) |> 125 | I.blend (ctrl_pt c2) |> I.blend (tangent p2 c2) |> 126 | I.blend (end_pt p2) |> I.move at 127 | in 128 | let smooth_quadratic ?(rel=false) ~at p0 c0 p1 p2 = 129 | let curve = P.empty |> P.sub p0 |> 130 | P.qcurve ~rel c0 p1 |> P.smooth_qcurve ~rel p2 131 | in 132 | let smooth = P2.tr (M3.rot2 ~pt:p1 Float.pi) c0 in 133 | let c0 = if rel then V2.(c0 + p0) else c0 in 134 | let p1 = if rel then V2.(p1 + p0) else p1 in 135 | let p2 = if rel then V2.(p2 + p1) else p2 in 136 | mgray |> I.cut ~area:(`O { P.o with P.width = 0.02 }) curve |> 137 | I.blend (tangent p0 c0) |> I.blend (tangent p1 c0) |> 138 | I.blend (ctrl_pt c0) |> I.blend (ctrl_pt c0) |> 139 | I.blend (end_pt p0) |> I.blend (end_pt p1) |> 140 | I.blend (smooth_pt smooth) |> I.blend (tangent p1 smooth) |> 141 | I.blend (tangent p2 smooth) |> 142 | I.blend (end_pt p2) |> I.move at 143 | in 144 | let tr p = 145 | p |> P2.tr (M3.rot2 (-. Float.pi_div_4)) |> P2.tr (M3.scale2 (V2.v 0.75 0.50)) 146 | in 147 | let p0 = P2.v 0.0 0.0 in 148 | let c0 = P2.v 0.0 t in 149 | let c1 = P2.v (1. -. t) 1. in 150 | let p1 = P2.v 1. 1. in 151 | let c2 = P2.v 2. t in 152 | let p2 = P2.v 2. 0. in 153 | let b00 = smooth_cubic ~at:(P2.v 0.00 4.00) p0 c0 c1 p1 c2 p2 in 154 | let p0 = tr p0 in 155 | let c0 = tr c0 in 156 | let c1 = tr c1 in 157 | let p1 = tr p1 in 158 | let c2 = tr c2 in 159 | let p2 = tr p2 in 160 | let b01 = smooth_cubic ~at:(P2.v 2.5 5.) p0 c0 c1 p1 c2 p2 in 161 | let p0 = P2.v 0. 0. in 162 | let c0 = P2.v 0. 1. in 163 | let p1 = P2.v 1. 1. in 164 | let p2 = P2.v 2. 0. in 165 | let b10 = smooth_quadratic ~at:(P2.v 0. 2.5) p0 c0 p1 p2 in 166 | let p0 = tr p0 in 167 | let c0 = tr c0 in 168 | let p1 = tr p1 in 169 | let p2 = tr p2 in 170 | let b11 = smooth_quadratic ~at:(P2.v 2.5 3.5) p0 c0 p1 p2 in 171 | let q0 = P2.v 0.0 0.0 in 172 | let d0 = P2.v 0.0 t in 173 | let d1 = P2.v (1. -. t) 1. in 174 | let q1 = P2.v 1. 1. in 175 | let d2 = P2.v 1. (-. (1. -. t)) in 176 | let q2 = P2.v 1. (-. 1.) in 177 | let b20 = smooth_cubic ~rel:true ~at:(P2.v 0. 1.5) q0 d0 d1 q1 d2 q2 in 178 | let q0 = P2.v 0. 0. in 179 | let d0 = P2.v 0. 1. in 180 | let q1 = P2.v 1. 1. in 181 | let q2 = P2.v 1. (-. 1.) in 182 | let b21 = smooth_quadratic ~rel:true ~at:(P2.v 2.5 1.5) q0 d0 q1 q2 in 183 | (* let b01 = cubic ~at:(P2.v 2.85 3.60) p0 c1 c2 pb in *) 184 | (* let b10 = cubic ~at:(P2.v 0.50 1.75) p0 c1 c2 pc in *) 185 | (* let b11 = cubic ~at:(P2.v 3.15 1.75) p0 c1 c2 pd in *) 186 | b00 |> I.blend b01 |> I.blend b10 |> I.blend b11 |> I.blend b20 |> I.blend b21 187 | end; 188 | 189 | Db.image "path-dashes" __POS__ ~author:Db.dbuenzli 190 | ~title:"Dash patterns" 191 | ~tags:["path"; "dashes";] 192 | ~note:"Miscellaneous dash patterns and offsets. " 193 | ~size:(Size2.v 100. 100.) 194 | ~view:(Box2.v P2.o (Size2.v 26. 26.)) 195 | begin fun _ -> 196 | let path = P.empty |> P.sub (P2.v 1. 0.) |> P.line (P2.v 25. 0.) in 197 | let line y d = 198 | let area = `O { P.o with P.dashes = Some d } in 199 | Color.gray 0.3 |> I.const |> I.cut ~area path |> I.move (V2.v 0. y) 200 | in 201 | line 25. (0., []) |> 202 | I.blend (line 23. (0., [1.])) |> 203 | I.blend (line 21. (1., [1.])) |> 204 | I.blend (line 19. (0., [2.])) |> 205 | I.blend (line 17. (1., [2.])) |> 206 | I.blend (line 15. (1., [2.; 1.])) |> 207 | I.blend (line 13. (6., [3.; 5.])) |> 208 | I.blend (line 11. (0., [2.; 3.])) |> 209 | I.blend (line 9. (11., [2.; 3.])) |> 210 | I.blend (line 7. (0., [2.; 1.; 3.])) |> 211 | I.blend (line 5. (0., [2.; 1.; 3.; 2.])) |> 212 | I.blend (line 3. (1., [1.; 5.])) |> 213 | I.blend (line 1. (0., [5.; 1.])) 214 | end; 215 | 216 | Db.image "path-cantor-dashes" __POS__ ~author:Db.dbuenzli 217 | ~title:"Cantor set with dashes" 218 | ~tags:["path"; "fractal"; "dashes";] 219 | ~note:"The Cantor set is drawn with dashes to represent its elements. \ 220 | Maximal dash pattern size is a largely undocumented parameter of \ 221 | the renderer backends, the line renderings may quickly become \ 222 | incorrect (e.g. ghostscript says the file is broken)." 223 | ~size:(Size2.v 120. 90.) 224 | ~view:(Box2.v P2.o (Size2.v 1.2 0.9)) 225 | begin fun _ -> 226 | (* Cantor set http://mathworld.wolfram.com/CantorSet.html *) 227 | let unit = P.empty |> P.line V2.ox in 228 | let o = { P.o with P.width = 0.05 } in 229 | let cantor max = 230 | let rec split odd acc = function 231 | | [] -> acc 232 | | d :: l -> 233 | if odd then split false (d :: acc) l else 234 | let d' = d /. 3. in 235 | split true (d' :: d' :: d' :: acc) l 236 | in 237 | let rec loop level i dashes = 238 | if level < 0 then i else 239 | let pat = (* only half + 1 of the dashes are needed. *) 240 | let rec keep c l acc = 241 | if c = 0 then List.rev acc else 242 | keep (c - 1) (List.tl l) ((List.hd l) :: acc) 243 | in 244 | keep (List.length dashes / 2 + 1) dashes [] 245 | in 246 | let area = `O { o with P.dashes = Some (0., pat); } in 247 | let i' = 248 | I.const (Color.gray 0.3) |> I.cut ~area unit |> 249 | I.move (P2.v 0. (0.1 *. float level)) |> I.blend i 250 | in 251 | loop (level - 1) i' (split false [] dashes) 252 | in 253 | loop max I.void [ 1. ] 254 | in 255 | cantor 6 |> I.move (P2.v 0.1 0.15) 256 | end; 257 | 258 | Db.image "path-derived" __POS__ ~author:Db.dbuenzli 259 | ~title:"Derived subpath of Vg.P" 260 | ~tags:["path";] 261 | ~note:"From inward to outward, ellipse, circle, rectangle, rectangle \ 262 | with elliptic corners." 263 | ~size:(Size2.v 50. 50.) 264 | ~view:(Box2.v P2.o (Size2.v 1. 1.)) 265 | begin fun _ -> 266 | let c = P2.v 0.5 0.5 in 267 | let p = 268 | P.empty |> 269 | P.ellipse c (V2.v 0.1 0.2) |> 270 | P.circle c 0.25 |> 271 | P.rect (Box2.v (P2.v 0.2 0.15) (Size2.v 0.6 0.7)) |> 272 | P.rrect (Box2.v (P2.v 0.1 0.05) (Size2.v 0.8 0.9)) (Size2.v 0.2 0.1) 273 | in 274 | let area = `O { P.o with P.width = 0.01 } in 275 | I.const (Color.gray 0.3) |> I.cut ~area p 276 | end; 277 | 278 | Db.image "path-miter-angle" __POS__ ~author:Db.dbuenzli 279 | ~title:"Miter angle limit" 280 | ~tags:["path";] 281 | ~note:"In the left column the miter angle is set below the angle made by \ 282 | the path, all joins should be pointy. In the right column the miter \ 283 | angle is set above the angle made by the path, all joins should be \ 284 | bevelled." 285 | ~size:(Size2.v 120. 570.) 286 | ~view:(Box2.v P2.o (Size2.v 4.0 19.0)) 287 | begin fun _ -> 288 | let gray = I.const (Color.gray 0.3) in 289 | let white = I.const Color.white in 290 | let wedge a = 291 | P.empty |> P.sub (V2.polar 0.6 a) |> P.line P2.o |> P.line (V2.v 0.6 0.) 292 | in 293 | let path x y miter_angle a = 294 | let area = (`O { P.o with P.width = 0.1; miter_angle }) in 295 | let wedge = wedge a in 296 | let outline = I.cut ~area wedge gray in 297 | let data = I.cut ~area:(`O { P.o with P.width = 0.01 }) wedge white in 298 | outline |> I.blend data |> I.move (P2.v x (y +. 0.2)) 299 | in 300 | let acc = ref I.void in 301 | for i = 0 to 18 do 302 | let y = float i in 303 | let base = y *. 10. in 304 | let a = Float.rad_of_deg base in 305 | let less = Float.rad_of_deg (base -. 1.) in 306 | let more = Float.rad_of_deg (base +. 1.) in 307 | acc := !acc |> I.blend (path 1. y less a) |> I.blend (path 3. y more a) 308 | done; 309 | !acc 310 | end; 311 | 312 | Db.image "path-circle-ellipse" __POS__ ~author:Db.dbuenzli 313 | ~note:"Shows dilation on line width due to scaling \ 314 | (from Christophe Troestler ocaml-cairo example tips_ellipse.ml). 315 | The form on the left is a scaled circle. The form on the right is 316 | an ellipse." 317 | ~title:"Line width dilation" 318 | ~tags:["path"] 319 | ~size:(Size2.v 120. 120.) 320 | ~view:(Box2.v P2.o (Size2.v 1. 1.)) 321 | begin fun _ -> 322 | let circle = 323 | let circle = P.(empty |> circle (P2.v 0.5 0.5) 0.4) in 324 | let area = `O { P.o with P.width = 0.1 } in 325 | I.cut ~area circle (I.const Color.black) |> 326 | I.scale (Size2.v 0.5 1.) 327 | in 328 | let ellipse = 329 | let ellipse = P.(empty |> ellipse (P2.v 0.5 0.5) (Size2.v 0.2 0.4)) in 330 | let area = `O { P.o with P.width = 0.1 } in 331 | I.cut ~area ellipse (I.const Color.black) |> 332 | I.move (V2.v 0.25 0.) 333 | in 334 | I.blend circle ellipse 335 | end 336 | -------------------------------------------------------------------------------- /test/db/rmark.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2013 The vg programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | open Gg 7 | open Vg 8 | 9 | (* Images with random marks. *) 10 | 11 | let mark_count = 1500 12 | let note = Printf.sprintf "%d marks." mark_count 13 | let size = Size2.v 120. 60. 14 | let view = Box2.v P2.o (Size2.v 120. 60.) 15 | let tags = ["image"] 16 | 17 | let random_marks m = 18 | let r = Random.State.make [|1557|] in 19 | let rx = Float.srandom r ~min:6. ~len:108. in 20 | let ry = Float.srandom r ~min:6. ~len:48. in 21 | let rpt () = V2.v (rx ()) (ry ()) in 22 | let rec rpts n acc = if n = 0 then acc else rpts (n-1) (rpt ():: acc) in 23 | let mark pt = 24 | let area = `O { P.o with P.width = 0.25 } in 25 | (I.const (Color.gray 0.9) |> I.cut m) |> I.blend 26 | (I.const (Color.gray 0.3) |> I.cut ~area m) |> 27 | I.move pt 28 | in 29 | let nodes = List.map mark (rpts mark_count []) in 30 | List.fold_left I.blend I.void nodes 31 | ;; 32 | 33 | Db.image "rmark-dots" __POS__ ~author:Db.dbuenzli 34 | ~title:"Random dot mark" 35 | ~tags ~note ~size ~view 36 | begin fun _ -> 37 | random_marks (P.empty |> P.circle P2.o 2.1) 38 | end; 39 | 40 | Db.image "rmark-ticks" __POS__ ~author:Db.dbuenzli 41 | ~title:"Random line mark" 42 | ~tags ~note ~size ~view 43 | begin fun _ -> 44 | random_marks (P.empty |> P.line (P2.v 0.5 1.1)) 45 | end; 46 | 47 | Db.image "rmark-qcurve" __POS__ ~author:Db.dbuenzli 48 | ~title:"Random quadratic mark" 49 | ~tags ~note ~size ~view 50 | begin fun _ -> 51 | random_marks 52 | (P.empty |> P.qcurve (P2.v 1.0 1.5) (P2.v 1.0 0.0)) 53 | end; 54 | 55 | Db.image "rmark-ccurve" __POS__ ~author:Db.dbuenzli 56 | ~title:"Random cubic mark" 57 | ~tags ~note ~size ~view 58 | begin fun _ -> 59 | random_marks 60 | (P.empty |> P.ccurve (P2.v 0.5 1.0) (P2.v 1.0 1.5) (P2.v 1.0 0.0)) 61 | end; 62 | -------------------------------------------------------------------------------- /test/db/uncut.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2013 The vg programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | open Gg 7 | open Vg 8 | 9 | (** Test images for uncut image primitives. *) 10 | 11 | let emerald = Color.v_srgb 0.314 0.784 0.471 12 | ;; 13 | 14 | Db.image "uncut-const" __POS__ ~author:Db.dbuenzli 15 | ~title:"Uncut constant emerald image" 16 | ~tags:["uncut"] 17 | ~note:"Constant emerald color over the rectangle." 18 | ~size:(Size2.v 120. 60.) 19 | ~view:(Box2.v P2.o (P2.v 2. 1.)) 20 | begin fun _ -> 21 | I.const emerald 22 | end; 23 | 24 | Db.image "uncut-const-tr" __POS__ ~author:Db.dbuenzli 25 | ~title:"Uncut transformed constant image" 26 | ~tags:["uncut"] 27 | ~note:"Constant emerald color over the rectangle." 28 | ~size:(Size2.v 120. 60.) 29 | ~view:(Box2.v P2.o (P2.v 2. 1.)) 30 | begin fun _ -> 31 | I.const emerald |> 32 | I.move (V2.v 1. 1.) |> I.scale (V2.v 3. 4.) |> I.blend I.void |> 33 | I.move (V2.v 0.25 0.0) 34 | end; 35 | 36 | Db.image "uncut-axial" __POS__ ~author:Db.dbuenzli 37 | ~title:"Uncut axial gradient image" 38 | ~tags:["uncut"; "gradient"] 39 | ~note:"From left to right: black to emerald axial gradient." 40 | ~size:(Size2.v 120. 60.) 41 | ~view:(Box2.v P2.o (Size2.v 2. 1.)) 42 | begin fun _ -> 43 | let stops = [0.0, Color.black; 1.0, emerald] in 44 | I.axial stops P2.o (P2.v 2. 0.) 45 | end; 46 | 47 | Db.image "uncut-axial-tr" __POS__ ~author:Db.dbuenzli 48 | ~title:"Uncut transformed axial gradient image" 49 | ~tags:["uncut"; "gradient"] 50 | ~note:"From left to right: black to emerald axial gradient." 51 | ~size:(Size2.v 120. 60.) 52 | ~view:(Box2.v P2.o (Size2.v 2. 1.)) 53 | begin fun _ -> 54 | let stops = [0.0, Color.black; 1.0, emerald] in 55 | I.axial stops (P2.v (-1.) (0.)) (P2.v 3. 0.) |> 56 | I.move (V2.v 0.5 0.0) |> I.scale (V2.v 0.5 1.0) |> I.blend I.void |> 57 | I.move (V2.v 0.25 0.0) 58 | end; 59 | 60 | Db.image "uncut-radial" __POS__ ~author:Db.dbuenzli 61 | ~title:"Uncut radial gradient image" 62 | ~tags:["uncut"; "gradient"] 63 | ~note:"Centered, from inwards to outwards: black to emerald radial gradient." 64 | ~size:(Size2.v 120. 60.) 65 | ~view:(Box2.v P2.o (Size2.v 2. 1.)) 66 | begin fun _ -> 67 | let stops = [0.0, Color.black; 1.0, emerald] in 68 | I.radial stops (P2.v 1.0 0.5) 1.0 69 | end; 70 | 71 | Db.image "uncut-radial-tr" __POS__ ~author:Db.dbuenzli 72 | ~title:"Uncut transformed radial gradient image" 73 | ~tags:["uncut"; "gradient"] 74 | ~note:"Centered, from inwards to outwards: black to emerald radial gradient." 75 | ~size:(Size2.v 120. 60.) 76 | ~view:(Box2.v P2.o (Size2.v 2. 1.)) 77 | begin fun _ -> 78 | let stops = [0.0, Color.black; 1.0, emerald] in 79 | I.radial stops P2.o 2.0 |> 80 | I.move (V2.v 0.5 0.5) |> I.scale (V2.v 0.5 0.5) |> I.blend I.void |> 81 | I.move (V2.v 0.75 0.25) 82 | end; 83 | -------------------------------------------------------------------------------- /test/db_viewer.html: -------------------------------------------------------------------------------- 1 | 2 | 6 | 7 | 8 | 9 | 10 | 11 | 166 | Vg image database 167 | 168 | 169 | 170 | 171 | 172 | -------------------------------------------------------------------------------- /test/examples.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2024 The vg programmers. All rights reserved. 3 | SPDX-License-Identifier: CC0-1.0 4 | ---------------------------------------------------------------------------*) 5 | 6 | open Gg 7 | open Vg 8 | 9 | let gray = I.const (Color.gray 0.5) 10 | 11 | let svg_of_unit_square i = 12 | try 13 | Out_channel.with_open_bin "/tmp/vg-tutorial.svg" @@ fun oc -> 14 | let size = Size2.v 30. 30. (* mm *) in 15 | let view = Box2.unit in 16 | let r = Vgr.create (Vgr_svg.target ()) (`Channel oc) in 17 | ignore (Vgr.render r (`Image (size, view, i))); 18 | ignore (Vgr.render r `End); 19 | with Sys_error e -> prerr_endline e 20 | 21 | let () = svg_of_unit_square gray 22 | 23 | 24 | let circle = P.empty |> P.circle (P2.v 0.5 0.5) 0.4 25 | let gray_circle = I.cut circle gray 26 | 27 | let circle_outline = 28 | let area = `O { P.o with P.width = 0.04 } in 29 | let blue = I.const (Color.v_srgb 0.000 0.439 0.722) in 30 | I.cut ~area circle blue 31 | 32 | let dot = I.blend circle_outline gray_circle 33 | let dot = gray_circle |> I.blend circle_outline 34 | 35 | let scatter_plot pts pt_width = 36 | let dot = 37 | let circle = P.empty |> P.circle P2.o (0.5 *. pt_width) in 38 | I.const (Color.v_srgb 0.000 0.439 0.722) |> I.cut circle 39 | in 40 | let mark pt = dot |> I.move pt in 41 | let blend_mark acc pt = acc |> I.blend (mark pt) in 42 | List.fold_left blend_mark I.void pts 43 | 44 | let subs = 45 | let p = 46 | let rel = true in 47 | P.empty |> 48 | P.sub (P2.v 0.1 0.5) |> 49 | P.line (P2.v 0.3 0.5) |> 50 | P.qcurve ~rel (P2.v 0.2 0.5) (P2.v 0.2 0.0) |> 51 | P.ccurve ~rel (P2.v 0.0 (-. 0.5)) (P2.v 0.1 (-. 0.5)) (P2.v 0.3 0.0) |> 52 | P.earc ~rel (Size2.v 0.1 0.2) (P2.v 0.15 0.0) |> 53 | P.sub (P2.v 0.18 0.26) |> 54 | P.qcurve ~rel (P2.v (0.01) (-0.1)) (P2.v 0.1 (-. 0.05)) |> 55 | P.close |> 56 | P.sub (P2.v 0.65 0.8) |> 57 | P.line ~rel (P2.v 0.1 (-. 0.05)) 58 | in 59 | let area = `O { P.o with P.width = 0.01 } in 60 | I.const (Color.v_srgb 0.000 0.439 0.722) |> I.cut ~area p 61 | -------------------------------------------------------------------------------- /test/font_glyphs.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2014 The vg programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | (* Renders a font's glyphs to a PDF file (does not use Vg's glyph API). *) 7 | 8 | open Gg 9 | open Vg 10 | 11 | let str = Printf.sprintf 12 | let otfm_err_str err = 13 | Format.fprintf Format.str_formatter "%a" Otfm.pp_error err; 14 | Format.flush_str_formatter () 15 | 16 | let string_of_file inf = 17 | try 18 | let ic = if inf = "-" then stdin else open_in_bin inf in 19 | let close ic = if inf <> "-" then close_in ic else () in 20 | let buf_size = 65536 in 21 | let b = Buffer.create buf_size in 22 | let s = Bytes.create buf_size in 23 | try 24 | while true do 25 | let c = input ic s 0 buf_size in 26 | if c = 0 then raise Exit else 27 | Buffer.add_subbytes b s 0 c 28 | done; 29 | assert false 30 | with 31 | | Exit -> close ic; Ok (Buffer.contents b) 32 | | Failure _ -> close ic; Error (str "%s: input file too large" inf) 33 | | Sys_error e -> close ic; Error (str "%s: %s" inf e) 34 | with 35 | | Sys_error e -> Error (str "%s: %s" inf e) 36 | 37 | (* Font information *) 38 | 39 | module Int = struct type t = int let compare = compare end 40 | module Gmap = Map.Make (Int) (* glyph id maps *) 41 | 42 | type otf_info = 43 | { i_otf : string; (* The font bytes. *) 44 | i_name : string; (* PostScript name. *) 45 | i_units_per_em : int; (* Number of units per em. *) 46 | i_bbox : int * int * int * int; (* glyphs bounding box. *) 47 | i_glyph_count : int; (* glyph count. *) 48 | i_outlines : Otfm.glyph_descr Gmap.t; } (* maps glyph ids to outlines. *) 49 | 50 | let decode_outlines gcount d = 51 | let ( >>= ) x f = match x with Error _ as e -> e | Ok v -> f v in 52 | let rec loop i acc = 53 | if i < 0 then Ok acc else 54 | Otfm.loca d i 55 | >>= function 56 | | None -> loop (i - 1) acc 57 | | Some loc -> Otfm.glyf d loc >>= fun o -> loop (i - 1) (Gmap.add i o acc) 58 | in 59 | loop (gcount - 1) Gmap.empty 60 | 61 | let font_info inf = match string_of_file inf with 62 | | Error _ as e -> e 63 | | Ok i_otf -> 64 | let ( >>= ) x f = match x with 65 | | Error e -> Error (str "%s: %s" inf (otfm_err_str e)) 66 | | Ok v -> f v 67 | in 68 | let d = Otfm.decoder (`String i_otf) in 69 | Otfm.postscript_name d 70 | >>= fun name -> Otfm.head d 71 | >>= fun headt -> Otfm.glyph_count d 72 | >>= fun i_glyph_count -> decode_outlines i_glyph_count d 73 | >>= fun i_outlines -> 74 | let i_name = match name with None -> "Unknown" | Some n -> n in 75 | let i_units_per_em = headt.Otfm.head_units_per_em in 76 | let i_bbox = Otfm.(headt.head_xmin, headt.head_ymin, 77 | headt.head_xmax, headt.head_ymax) 78 | in 79 | Ok ({ i_otf; i_name; i_units_per_em; i_glyph_count; i_bbox; i_outlines }) 80 | 81 | let font_bbox fi fsize = 82 | let u_to_em = float fi.i_units_per_em in 83 | let size v = (fsize *. (float v)) /. u_to_em in 84 | let size_pt x y = P2.v (size x) (size y) in 85 | let minx, miny, maxx, maxy = fi.i_bbox in 86 | Box2.of_pts (size_pt minx miny) (size_pt maxx maxy) 87 | 88 | let add_contours tr size contours acc = 89 | let add_contour acc contour = 90 | if contour = [] then acc else 91 | let pt = match tr with 92 | | None -> fun x y -> P2.v (size x) (size y) 93 | | Some ((dx,dy), None) -> fun x y -> P2.v (size (x + dx)) (size (y + dy)) 94 | | Some ((dx,dy), Some (a, b, c, d)) -> 95 | let m2 = M2.v a c b d in 96 | fun x y -> 97 | let x, y = V2.to_tuple (V2.ltr m2 (P2.v (float x) (float y))) in 98 | (* TODO maybe we should avoid going through ints again. 99 | In any case the spec is very underspecified on the order 100 | these things should happen. But this seems to yield 101 | correct results. *) 102 | P2.v 103 | (size (Float.int_of_round x + dx)) 104 | (size (Float.int_of_round y + dy)) 105 | in 106 | let find_start acc = match contour with 107 | | (true, px, py as p) :: pts -> 108 | [p], p, acc |> P.sub (pt px py), pts 109 | | (false, cx, cy as c) :: (true, px, py as p) :: pts -> 110 | [c; p], p, acc |> P.sub (pt px py), pts 111 | | (false, cx, cy as c) :: ((false, cx', cy') :: _ as pts) -> 112 | let px = (cx + cx') / 2 in 113 | let py = (cy + cy') / 2 in 114 | let p = (true, px, py) in 115 | [c; p], p, acc |> P.sub (pt px py), pts 116 | | pts -> (* degenerate *) 117 | [true, 0, 0], (true, 0, 0), acc |> P.sub P2.o, pts 118 | in 119 | let rec add_pts ends (last_on, lx, ly) acc = function 120 | | (false, cx, cy as last) :: pts -> 121 | if last_on then add_pts ends last acc pts else 122 | let px = (lx + cx) / 2 in 123 | let py = (ly + cy) / 2 in 124 | let acc' = acc |> P.qcurve (pt lx ly) (pt px py) in 125 | add_pts ends last acc' pts 126 | | (true, px, py as last) :: pts -> 127 | let seg = 128 | if last_on then P.line (pt px py) else 129 | P.qcurve (pt lx ly) (pt px py) 130 | in 131 | add_pts ends last (acc |> seg) pts 132 | | [] -> 133 | if last_on then begin match ends with 134 | | [(true, px, py)] -> 135 | acc 136 | |> P.line (pt px py) 137 | |> P.close 138 | | [(false, cx, cy); (true, px, py)] -> 139 | acc 140 | |> P.qcurve (pt cx cy) (pt px py) 141 | |> P.close 142 | | _ -> assert false 143 | end else begin match ends with 144 | | [(true, px, py)] -> 145 | acc 146 | |> P.qcurve (pt lx ly) (pt px py) 147 | |> P.close 148 | | [(false, cx, cy); (true, px, py)] -> 149 | let nx = (lx + cx) / 2 in 150 | let ny = (ly + cy) / 2 in 151 | acc 152 | |> P.qcurve (pt lx ly) (pt nx ny) 153 | |> P.qcurve (pt cx cy) (pt px py) 154 | |> P.close 155 | | _ -> assert false 156 | end 157 | in 158 | let ends, last, acc, pts = find_start acc in 159 | add_pts ends last acc pts 160 | in 161 | List.fold_left add_contour acc contours 162 | 163 | let glyph_path fi i fsize = 164 | let u_to_em = float fi.i_units_per_em in 165 | let size v = (fsize *. (float v)) /. u_to_em in 166 | try match fst (Gmap.find i fi.i_outlines) with 167 | | `Simple contours -> add_contours None size contours P.empty 168 | | `Composite cs -> 169 | let rec add_composites acc = function 170 | | [] -> acc 171 | | (gid, dv, m) :: cs -> 172 | try match fst (Gmap.find gid fi.i_outlines) with 173 | | `Simple contours -> 174 | let acc' = add_contours (Some (dv, m)) size contours acc in 175 | add_composites acc' cs 176 | | `Composite cs -> 177 | (* TODO forbid recursive composite for now *) 178 | Printf.eprintf "Warning: unhandled recursive composite\n%!"; 179 | add_composites acc cs 180 | with 181 | | Not_found -> add_composites acc cs 182 | in 183 | add_composites P.empty cs 184 | with Not_found -> P.empty 185 | 186 | let renderable fi fsize cols nobb = 187 | let gcount = fi.i_glyph_count in 188 | let rows = (gcount / cols) + 1 in 189 | let bbox = font_bbox fi fsize in 190 | let pad = V2.(0.5 * Box2.size bbox) in 191 | let dglyph = V2.(Box2.size bbox + pad) in 192 | let margin = V2.(2. * Box2.size bbox) in 193 | let grid = V2.v (float cols) (float rows) in 194 | let gmax = V2.(grid - Size2.unit) in 195 | let size = V2.((mul grid (Box2.size bbox)) + (mul gmax pad) + 2. * margin) in 196 | let pos i = 197 | let idx = V2.v (float (i mod cols)) (float (i / cols)) in 198 | V2.(margin + (mul idx dglyph)) 199 | in 200 | let black = I.const Color.black in 201 | let bbox = 202 | if nobb then I.void else 203 | let area = `O { P.o with P.width = 0.01 *. fsize } in 204 | black |> I.cut ~area (P.empty |> P.rect bbox) 205 | in 206 | let rec add_glyphs acc i = 207 | if i = gcount then acc else 208 | let glyph = glyph_path fi i fsize in 209 | let glyph = bbox |> I.blend (black |> I.cut glyph) |> I.move (pos i) in 210 | add_glyphs (acc |> I.blend glyph) (i + 1) 211 | in 212 | let i = add_glyphs (I.const Color.white) 0 in 213 | let view = Box2.v P2.o size in 214 | `Image (size, view, i) 215 | 216 | let sample font size cols nobb = match font_info font with 217 | | Error _ as e -> e 218 | | Ok font_info -> 219 | let renderable = renderable font_info size cols nobb in 220 | let () = Out_channel.set_binary_mode stdout true in 221 | let r = Vgr.create (Vgr_pdf.target ()) (`Channel stdout) in 222 | ignore (Vgr.render r renderable); 223 | ignore (Vgr.render r `End); 224 | Ok () 225 | 226 | (* Command line *) 227 | 228 | let exec = Filename.basename Sys.executable_name 229 | let main () = 230 | let usage = Printf.sprintf 231 | "Usage: %s [OPTION]... [FONTFILE] \n\ 232 | Renders glyph outlines to a PDF document on stdout.\n\ 233 | Options:" exec 234 | in 235 | let font = ref None in 236 | let size = ref 5. in 237 | let cols = ref 10 in 238 | let nobb = ref false in 239 | let set_font s = 240 | if !font = None then font := Some s else 241 | raise (Arg.Bad "only a single font can be specified" ) 242 | in 243 | let options = [ 244 | "-s", (Arg.Set_float size), " SIZE, specify the font size (in mm)"; 245 | "-c", (Arg.Set_int cols), " NUM, specify number of columns"; 246 | "-nobb", (Arg.Set nobb), " don't print bounding boxes"; ] 247 | in 248 | Arg.parse (Arg.align options) set_font usage; 249 | match !font with 250 | | None -> Format.eprintf "%s: need to specify a font file" exec; exit 1 251 | | Some font -> 252 | match sample font !size !cols !nobb with 253 | | Error e -> Format.eprintf "%s: %s@." exec e; exit 1 254 | | Ok () -> exit 0 255 | 256 | let () = main () 257 | -------------------------------------------------------------------------------- /test/min_cairo_mem.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2024 The vg programmers. All rights reserved. 3 | SPDX-License-Identifier: CC0-1.0 4 | ---------------------------------------------------------------------------*) 5 | 6 | (* Minimal Vgr_cairo memory buffer image. Compile with: 7 | ocamlfind ocamlopt -package cairo2,gg,vg,vg.cairo -linkpkg min_cairo_mem.ml 8 | *) 9 | 10 | open Gg 11 | open Vg 12 | 13 | (* 1. Define your image *) 14 | 15 | let aspect = 1.618 16 | let size = Size2.v (aspect *. 100.) 100. (* mm *) 17 | let view = Box2.v P2.o (Size2.v aspect 1.) 18 | let image = I.const (Color.v_srgb 0.314 0.784 0.471) 19 | 20 | (* 2. Render *) 21 | 22 | let raster, stride = 23 | let res = 300. /. 25.4 (* 300dpi in dots per mm *) in 24 | let w = int_of_float (res *. Size2.w size) in 25 | let h = int_of_float (res *. Size2.h size) in 26 | let stride = Cairo.Image.(stride_for_width ARGB32 w) in 27 | let data = Bigarray.(Array1.create int8_unsigned c_layout (stride * h)) in 28 | let surface = Cairo.Image.(create_for_data8 data ARGB32 ~stride ~w ~h) in 29 | let ctx = Cairo.create surface in 30 | Cairo.scale ctx res res; 31 | let warn w = Vgr.pp_warning Format.err_formatter w in 32 | let r = Vgr.create ~warn (Vgr_cairo.target ctx) `Other in 33 | ignore (Vgr.render r (`Image (size, view, image))); 34 | ignore (Vgr.render r `End); 35 | Cairo.Surface.flush surface; 36 | Cairo.Surface.finish surface; 37 | data, stride 38 | -------------------------------------------------------------------------------- /test/min_cairo_png.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2024 The vg programmers. All rights reserved. 3 | SPDX-License-Identifier: CC0-1.0 4 | ---------------------------------------------------------------------------*) 5 | 6 | (* Minimal Vgr_cairo PNG example. Compile with: 7 | ocamlfind ocamlopt -package gg,vg,vg.cairo -linkpkg min_cairo_png.ml *) 8 | 9 | open Gg 10 | open Vg 11 | 12 | (* 1. Define your image *) 13 | 14 | let aspect = 1.618 15 | let size = Size2.v (aspect *. 100.) 100. (* mm *) 16 | let view = Box2.v P2.o (Size2.v aspect 1.) 17 | let image = I.const (Color.v_srgb 0.314 0.784 0.471) 18 | 19 | (* 2. Render *) 20 | 21 | let render oc = 22 | let res = 300. /. 0.0254 (* 300dpi in dots per meters *) in 23 | let format = `Png (Size2.v res res) in 24 | let warn w = Vgr.pp_warning Format.err_formatter w in 25 | let r = Vgr.create ~warn (Vgr_cairo.stored_target format) (`Channel oc) in 26 | ignore (Vgr.render r (`Image (size, view, image))); 27 | ignore (Vgr.render r `End) 28 | 29 | (* 3. Main *) 30 | 31 | let main () = Out_channel.set_binary_mode stdout true; render stdout; 0 32 | let () = if !Sys.interactive then () else exit (main ()) 33 | -------------------------------------------------------------------------------- /test/min_htmlc.html: -------------------------------------------------------------------------------- 1 | 2 | 6 | 7 | 8 | 9 | 10 | 11 | 14 | Vgr_htmlc minimal example 15 | 16 | 17 | 18 | 19 | 20 | -------------------------------------------------------------------------------- /test/min_htmlc.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2024 The vg programmers. All rights reserved. 3 | SPDX-License-Identifier: CC0-1.0 4 | ---------------------------------------------------------------------------*) 5 | 6 | (* Minimal Vgr_htmlc example. Compile with: 7 | ocamlfind ocamlc -package brr,gg,vg,vg.htmlc -linkpkg min_htmlc.ml 8 | js_of_ocaml -o min_htmlc.js a.out *) 9 | 10 | open Gg 11 | open Vg 12 | open Brr 13 | open Brr_canvas 14 | 15 | (* 1. Define your image *) 16 | 17 | let aspect = 1.618 18 | let size = Size2.v (aspect *. 100.) 100. (* mm *) 19 | let view = Box2.v P2.o (Size2.v aspect 1.) 20 | let image = I.const (Color.v_srgb 0.314 0.784 0.471) 21 | 22 | (* Browser bureaucracy. *) 23 | 24 | let main () = 25 | let cnv = Brr_canvas.Canvas.create [] (* 2 *) in 26 | let anchor = (* 3 *) 27 | let href = At.href (Jstr.v "#") in 28 | let title = At.title (Jstr.v "Download PNG file") in 29 | let download = At.v (Jstr.v "download") (Jstr.v "min_htmlc.png") in 30 | let a = El.a ~at:[href; title; download] [Brr_canvas.Canvas.to_el cnv] in 31 | El.append_children (Document.body G.document) [a]; a 32 | in 33 | let r = Vgr.create (Vgr_htmlc.target cnv) `Other in (* 4 *) 34 | ignore (Vgr.render r (`Image (size, view, image))); (* 5 *) 35 | ignore (Vgr.render r `End); 36 | let data = (* 6 *) 37 | Canvas.to_data_url cnv |> Console.log_if_error ~use:Jstr.empty 38 | in 39 | El.set_at At.Name.href (Some data) anchor 40 | 41 | let () = main () (* 7 *) 42 | -------------------------------------------------------------------------------- /test/min_pdf.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2024 The vg programmers. All rights reserved. 3 | SPDX-License-Identifier: CC0-1.0 4 | ---------------------------------------------------------------------------*) 5 | 6 | (* Minimal Vgr_pdf example. Compile with: 7 | ocamlfind ocamlopt -package gg,vg,vg.pdf min_pdf.ml *) 8 | 9 | open Gg 10 | open Vg 11 | 12 | (* 1. Define your image *) 13 | 14 | let aspect = 1.618 15 | let size = Size2.v (aspect *. 100.) 100. (* mm *) 16 | let view = Box2.v P2.o (Size2.v aspect 1.) 17 | let image = I.const (Color.v_srgb 0.314 0.784 0.471) 18 | 19 | (* 2. Render *) 20 | 21 | let render oc = 22 | let title = "Vgr_pdf minimal example" in 23 | let description = "Emerald Color" in 24 | let xmp = Vgr.xmp ~title ~description () in 25 | let warn w = Vgr.pp_warning Format.err_formatter w in 26 | let r = Vgr.create ~warn (Vgr_pdf.target ~xmp ()) (`Channel oc) in 27 | ignore (Vgr.render r (`Image (size, view, image))); 28 | ignore (Vgr.render r `End) 29 | 30 | (* 3. Main *) 31 | 32 | let main () = Out_channel.set_binary_mode stdout true; render stdout; 0 33 | let () = if !Sys.interactive then () else exit (main ()) 34 | -------------------------------------------------------------------------------- /test/min_svg.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2024 The vg programmers. All rights reserved. 3 | SPDX-License-Identifier: CC0-1.0 4 | ---------------------------------------------------------------------------*) 5 | 6 | (* Minimal Vgr_svg example. Compile with: 7 | ocamlfind ocamlopt -package gg,vg,vg.svg min_svg.ml *) 8 | 9 | open Gg 10 | open Vg 11 | 12 | (* 1. Define your image *) 13 | 14 | let aspect = 1.618 15 | let size = Size2.v (aspect *. 100.) 100. (* mm *) 16 | let view = Box2.v P2.o (Size2.v aspect 1.) 17 | let image = I.const (Color.v_srgb 0.314 0.784 0.471) 18 | 19 | (* 2. Render *) 20 | 21 | let render oc = 22 | let title = "Vgr_svg minimal example" in 23 | let description = "Emerald Color" in 24 | let xmp = Vgr.xmp ~title ~description () in 25 | let warn w = Vgr.pp_warning Format.err_formatter w in 26 | let r = Vgr.create ~warn (Vgr_svg.target ~xmp ()) (`Channel oc) in 27 | ignore (Vgr.render r (`Image (size, view, image))); 28 | ignore (Vgr.render r `End) 29 | 30 | (* 3. Main *) 31 | 32 | let main () = Out_channel.set_binary_mode stdout true; render stdout; 0 33 | let () = if !Sys.interactive then () else exit (main ()) 34 | -------------------------------------------------------------------------------- /test/mui.mli: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2013 The vg programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | (** Micro browser UI library 7 | 8 | Nothing serious and still ugly. 9 | 10 | Open the module to use it. It defines only modules in your scope 11 | and a single composition value. *) 12 | 13 | 14 | (** {1 UI elements} *) 15 | 16 | (** UI elements. *) 17 | module Ui : sig 18 | type 'a printer = Format.formatter -> 'a -> unit 19 | (** The type for value printers. *) 20 | 21 | type 'a t 22 | (** The type for UI elements defining values of type ['a]. *) 23 | 24 | type ('a, 'b) conf = 'a t * ('b -> unit) 25 | (** The type for UI elements and their configuration function. *) 26 | 27 | val on_change : 'a t -> ('a -> unit) -> unit 28 | (** [on_change ui f] calls [f] whenever the value of [ui] changes. 29 | Previous [on_change] function is overwritten. *) 30 | 31 | val show : 'a t -> unit 32 | (** [show ui] shows [ui] on screen. *) 33 | 34 | val main : (unit -> unit) -> unit 35 | (** [main setup] executes [setup ()] and runs the UI. *) 36 | 37 | (** {1 UI elements} *) 38 | 39 | val group : ?id:string -> unit -> unit t 40 | val label : ?id:string -> ?title:string -> ?ctrl:bool -> string -> string t 41 | val label_mut : ?id:string -> ?title:string -> ?ctrl:bool -> string -> 42 | (string, string) conf 43 | val text : ?id:string -> string -> (string, string) conf 44 | val bool : ?id:string -> bool -> (bool, bool) conf 45 | 46 | type link_conf = [ `Text of string | `Href of string | `Download of string ] 47 | val link : ?id:string -> ?title:string -> 48 | href:string -> string -> (unit, link_conf) conf 49 | 50 | type 'a select_conf = [ `Select of 'a option | `List of 'a list ] 51 | val select : ?id:string -> ?title:string -> 'a printer -> 'a option -> 52 | 'a list -> ('a option, 'a select_conf) conf 53 | 54 | val mselect : 55 | ?id:string -> ?title:string -> 'a printer -> 'a list -> 'a list -> 56 | ('a list, 'a list) conf 57 | 58 | val canvas : ?id:string -> unit -> unit t * Brr.El.t 59 | val canvas_data : Brr.El.t -> string 60 | (* val canvas_blob : Dom_html.canvasElement Js.t -> File.blob Js.t *) 61 | 62 | type object_conf = 63 | [ `Data of string | `Size of float * float | `Name of string] 64 | 65 | val object_ : ?id:string -> unit -> (unit, object_conf) conf 66 | 67 | type 'a menu_conf = [ `Select of 'a | `List of 'a list ] 68 | val menu : ?id:string -> 'a printer -> 'a -> 'a list -> 69 | ('a, 'a menu_conf) conf 70 | 71 | val classify : 'a t -> string -> bool -> unit 72 | val visible : ?relayout:bool -> 'a t -> bool -> unit 73 | val set_svg_child : 'a t -> string -> unit 74 | val set_txt_child : 'a t -> string -> unit 75 | (* val client_size : 'a t -> int * int *) 76 | val set_height : 'a t -> string -> unit 77 | val set_width : 'a t -> string -> unit 78 | 79 | val hash : unit -> string 80 | val set_hash : string -> unit 81 | val on_hash_change : (string -> unit) -> unit 82 | 83 | val escape_binary : string -> string 84 | (** [escape data] escapes the binary data [data]. *) 85 | end 86 | 87 | val ( *> ) : 'a Ui.t -> 'b Ui.t -> 'a Ui.t 88 | (** [p *> c] add [c] as a child to [p] and returns [p]. Left associative. *) 89 | 90 | (** {1 Persistent storage} *) 91 | 92 | (** Persistent storage. 93 | 94 | Safe if nobody messes with the storage outside of the program. 95 | 96 | {b WARNING} During developement code reorderings of {!key} will 97 | corrupt existing storage. {!Store.force_version} can mitigate that 98 | problem. *) 99 | module Store : sig 100 | 101 | (** {1 Storage scope and support} *) 102 | 103 | type scope = [ `Session | `Persist ] 104 | (** The storage scope. *) 105 | 106 | (** {1 Keys} *) 107 | 108 | type 'a key 109 | (** The type for keys whose lookup value is 'a *) 110 | 111 | val key : unit -> 'a key 112 | (** [key ()] is a new storage key. *) 113 | 114 | (** {1 Versioning} *) 115 | 116 | val force_version : ?scope:scope -> string -> unit 117 | (** [force_version v] checks that the version of the store is [v]. If 118 | it's not it {!clear}s the store and sets the version to [v]. *) 119 | 120 | (** {1 Storage} 121 | 122 | In the functions below [scope] defaults to [`Persist]. *) 123 | 124 | val mem : ?scope:scope -> 'a key -> bool 125 | (** [mem k] is [true] iff [k] has a mapping. *) 126 | 127 | val add : ?scope:scope -> 'a key -> 'a -> unit 128 | (** [add k v] maps [k] to [v]. *) 129 | 130 | val rem : ?scope:scope -> 'a key -> unit 131 | (** [rem k] unbinds [k]. *) 132 | 133 | val find : ?scope:scope -> 'a key -> 'a option 134 | (** [find k] is [k]'s mapping in [m], if any. *) 135 | 136 | val get : ?scope:scope -> ?absent:'a -> 'a key -> 'a 137 | (** [get k] is [k]'s mapping. If [absent] is provided and [m] has 138 | not binding for [k], [absent] is returned. 139 | 140 | @raise Invalid_argument if [k] is not bound and [absent] 141 | is unspecified. *) 142 | 143 | val clear : ?scope:scope -> unit -> unit 144 | (** [clear ()], clears all mapping. *) 145 | end 146 | 147 | (** {1 Timing and logging} *) 148 | 149 | (** Timing functions. *) 150 | module Time : sig 151 | val now : unit -> float 152 | (** [now ()] is the current UTC time as a Unix timestamp (in secs). *) 153 | 154 | val duration : ('a -> 'b) -> 'a -> float * 'b 155 | (** [duration f v] is [(t, f v)] with [t] the time taken by the call in 156 | seconds. *) 157 | 158 | val delay : float -> (unit -> unit) -> unit 159 | (** [delay s f] executes [f] in [s] seconds. *) 160 | end 161 | 162 | (** Logging functions. *) 163 | module Log : sig 164 | val msg_js : 'a -> unit 165 | (** [msg_js v] logs [v] as JavaScript a object. *) 166 | 167 | val msg : ('a, Format.formatter, unit) format -> 'a 168 | (** [msg] is like {!Format.printf} *) 169 | 170 | val err : ('a, Format.formatter, unit) format -> 'a 171 | (** [err] is like {!Format.eprintf} *) 172 | 173 | end 174 | -------------------------------------------------------------------------------- /test/sqc.html: -------------------------------------------------------------------------------- 1 | 2 | 6 | 7 | 8 | 9 | 11 | 12 | 21 | Square Circle Spiral Illusion 22 | 23 | 24 |

Square circle spiral illusion 25 | src. 26 | Originally found 27 | here. 28 |

29 | 31 | 32 | 33 | -------------------------------------------------------------------------------- /test/sqc.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2013 The vg programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | (* Illusion taken from http://bl.ocks.org/mbostock/1386444 7 | For now won't run smoothly on most machines/browsers. *) 8 | 9 | open Gg 10 | open Vg 11 | open Brr 12 | 13 | (* Illusion *) 14 | 15 | type ring = { radius : float; speed : float; } 16 | let rings = 17 | let r = 65. in 18 | [ { radius = 1. *. r; speed = 30. }; 19 | { radius = 2. *. r; speed = 20. }; 20 | { radius = 3. *. r; speed = 10. }; 21 | { radius = 4. *. r; speed = -10. }; 22 | { radius = 5. *. r; speed = -20. }; 23 | { radius = 6. *. r; speed = -30. }; ] 24 | 25 | let sq_width = 16. 26 | let sq_path = P.empty |> P.rect (Box2.v_mid P2.o (Size2.v sq_width sq_width)) 27 | let sq_outline = `O { P.o with P.width = 2.5 } 28 | let white_square = I.const Color.white |> I.cut ~area:sq_outline sq_path 29 | let black_square = I.const Color.black |> I.cut ~area:sq_outline sq_path 30 | let background = I.const (Color.gray 0.53) 31 | 32 | let ring dt r = 33 | let rot = Float.rad_of_deg (r.speed *. dt) in 34 | let white_square = white_square |> I.rot rot in 35 | let black_square = black_square |> I.rot rot in 36 | let n = Float.two_pi *. r.radius /. sq_width *. (sqrt 0.5) in 37 | let k = Float.two_pi /. n in 38 | let radius = V2.v 0. r.radius in 39 | let rec squares acc n = 40 | if n = 0 then acc else 41 | let sq = if n mod 2 = 0 then white_square else black_square in 42 | let acc' = acc |> I.blend (sq |> I.move radius |> I.rot ((float n) *. k)) in 43 | squares acc' (n - 1) 44 | in 45 | squares I.void (truncate n) |> I.rot rot 46 | 47 | let image ~dt = 48 | let add_ring acc r = acc |> I.blend (ring dt r) in 49 | let rings = List.fold_left add_ring I.void rings in 50 | background |> I.blend rings |> I.scale (V2.v 0.6 0.6) 51 | 52 | let size = Size2.v 150. 150. 53 | let view = Box2.v_mid P2.o (Size2.v 550. 550.) 54 | 55 | let main () = 56 | let c = Brr_canvas.Canvas.create [] in 57 | let r = Vgr.create (Vgr_htmlc.target c) `Other in 58 | let rec animate now = 59 | let i = image ~dt:(now /. 1000.) in 60 | ignore (Vgr.render r (`Image (size, view, i))); 61 | ignore (G.request_animation_frame animate) 62 | in 63 | El.append_children (Document.body G.document) [Brr_canvas.Canvas.to_el c]; 64 | ignore (G.request_animation_frame animate) 65 | 66 | let () = main () 67 | -------------------------------------------------------------------------------- /test/test_vgr_cairo.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2014 The vg programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | open Gg 7 | open Vg 8 | 9 | include Db_contents 10 | 11 | let dpi300 = let s = 300. /. 0.0254 in Size2.v s s 12 | 13 | let formats = 14 | [ ("png", false), `Png dpi300; 15 | ("pdf", true), `Pdf; 16 | ("ps", true), `Ps; 17 | ("svg", false), `Svg; ] 18 | 19 | let renderer fmt dst _ = 20 | let cairo_fmt = List.assoc fmt formats in 21 | Vgr.create (Vgr_cairo.stored_target cairo_fmt) dst 22 | 23 | let ftypes = List.map fst formats 24 | let () = 25 | Test_vgr_stored.main_multiformats "PNG, PDF, PS or SVG" ftypes renderer 26 | -------------------------------------------------------------------------------- /test/test_vgr_pdf.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2013 The vg programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | (* Renders the Vg image database to PDF. *) 7 | 8 | open Vg 9 | include Db_contents 10 | 11 | let renderer dst is = 12 | let open_sans_xbold = match Vgr_pdf.otf_font Open_sans.extra_bold with 13 | | Error e -> Format.eprintf "%a" Otfm.pp_error e; `Sans 14 | | Ok otf -> otf 15 | in 16 | let font f = match f.Font.name, f.Font.weight with 17 | | "Open Sans", `W800 -> open_sans_xbold 18 | | _ -> Vgr_pdf.font f 19 | in 20 | Vgr.create (Vgr_pdf.target ~font ~xmp:(Test_vgr_stored.xmp is) ()) dst 21 | 22 | let () = Test_vgr_stored.main "PDF" "pdf" ~pack:true renderer 23 | -------------------------------------------------------------------------------- /test/test_vgr_stored.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2013 The vg programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | (* Generic infrastructure for rendering Vg's image db on stored destinations. *) 7 | 8 | open Gg 9 | open Vg 10 | 11 | let str = Printf.sprintf 12 | let pp = Format.fprintf 13 | let pp_dur ppf dur = pp ppf "%.2fms" (dur *. 1000.) 14 | let pp_str = Format.pp_print_string 15 | let rec pp_list ?(pp_sep = Format.pp_print_cut) pp_v ppf = function 16 | | [] -> () 17 | | v :: vs -> 18 | pp_v ppf v; if vs <> [] then (pp_sep ppf (); pp_list ~pp_sep pp_v ppf vs) 19 | 20 | let pp_text ppf s = (* hint spaces and new lines with Format's funs *) 21 | let len = String.length s in 22 | let left = ref 0 in 23 | let right = ref 0 in 24 | let flush () = 25 | pp_str ppf (String.sub s !left (!right - !left)); 26 | incr right; left := !right; 27 | in 28 | while (!right <> len) do 29 | if s.[!right] = '\n' then (flush (); Format.pp_force_newline ppf ()) else 30 | if s.[!right] = ' ' then (flush (); Format.pp_print_space ppf ()) else 31 | incr right 32 | done; 33 | if !left <> len then flush () 34 | 35 | let exec = Filename.basename Sys.executable_name 36 | let log_msg fmt = Format.eprintf ("%s: " ^^ fmt ^^ "@?") exec 37 | let log fmt = Format.eprintf (fmt ^^ "@?") 38 | let duration f x = 39 | let start = Unix.gettimeofday () in 40 | f x; Unix.gettimeofday () -. start 41 | 42 | (* Metadata *) 43 | 44 | let xmp is = 45 | let create_date = Unix.gettimeofday () in 46 | let creator_tool = exec in 47 | match is with 48 | | [i] -> Db.xmp ~create_date ~creator_tool i 49 | | _ -> Vgr.xmp ~create_date ~creator_tool () 50 | 51 | (* Render *) 52 | 53 | let unix_buffer_size = 65536 (* UNIX_BUFFER_SIZE 4.0.0 *) 54 | let rec unix_write fd s j l = 55 | let rec write fd s j l = try Unix.single_write fd s j l with 56 | | Unix.Unix_error (Unix.EINTR, _, _) -> write fd s j l 57 | in 58 | let wc = write fd s j l in 59 | if wc < l then unix_write fd s (j + wc) (l - wc) else () 60 | 61 | let string_to_channel use_unix oc s = 62 | if use_unix 63 | then unix_write (Unix.descr_of_out_channel oc) s 0 (Bytes.length s) 64 | else output_bytes oc s 65 | 66 | let rec render_unix fd s r v = match Vgr.render r v with 67 | | `Ok -> () 68 | | `Partial -> 69 | unix_write fd s 0 (Bytes.length s - Vgr.Manual.dst_rem r); 70 | Vgr.Manual.dst r s 0 (Bytes.length s); 71 | render_unix fd s r `Await 72 | 73 | let rec render_imgs render r = function 74 | | [] -> ignore (render r `End) 75 | | i :: is -> 76 | ignore (render r (`Image (Db.renderable i))); 77 | render_imgs render r is 78 | 79 | let render_with_channel fn renderer imgs = 80 | let oc = open_out fn in 81 | let r = renderer (`Channel oc) imgs in 82 | try 83 | render_imgs Vgr.render r imgs; 84 | close_out oc 85 | with e -> close_out oc; raise e 86 | 87 | let render_with_buffer buf use_unix fn renderer imgs = 88 | let oc = open_out fn in 89 | let r = renderer (`Buffer buf) imgs in 90 | try 91 | render_imgs Vgr.render r imgs; 92 | string_to_channel use_unix oc (Buffer.to_bytes buf); 93 | close_out oc; 94 | with e -> close_out oc; raise e 95 | 96 | let render_with_unix s fn renderer imgs = 97 | let fd = Unix.(openfile fn [O_WRONLY] 0) in 98 | let r = renderer `Manual imgs in 99 | try 100 | Vgr.Manual.dst r s 0 (Bytes.length s); 101 | render_imgs (render_unix fd s) r imgs; 102 | Unix.close fd; 103 | with e -> Unix.close fd; raise e 104 | 105 | let render sout use_unix usize dir ftype pack renderer imgs = 106 | let render = 107 | if sout then render_with_buffer (Buffer.create usize) use_unix else 108 | if use_unix then render_with_unix (Bytes.create usize) else 109 | render_with_channel 110 | in 111 | let render_to_file fn img = try 112 | log "Writing %s @?" fn; 113 | let dur = duration (render fn renderer) img in 114 | log "(%a) [DONE]@." pp_dur dur; 115 | with 116 | | Sys_error e -> log "[FAIL]@."; log_msg "%s@." e; exit 1 117 | | Unix.Unix_error (e, _, v) -> 118 | log "[FAIL]@."; log_msg "%s: %s@." (Unix.error_message e) v; exit 1 119 | in 120 | let fname id = Filename.concat dir (str "%s.%s" id (fst ftype)) in 121 | match pack with 122 | | None -> List.iter (fun i -> render_to_file (fname i.Db.id) [i]) imgs 123 | | Some pack when not (snd ftype) -> 124 | log "Sorry cannot -pack the %s format." (fst ftype); exit 1 125 | | Some pack -> 126 | render_to_file (fname pack) imgs 127 | 128 | (* Dump textual representation. *) 129 | 130 | let dump dir ftype i = try 131 | let fn = Filename.concat dir (str "%s.%s.dump" i.Db.id ftype) in 132 | let oc = open_out fn in 133 | let ppf = Format.formatter_of_out_channel oc in 134 | try 135 | log "Writing %s @?" fn; 136 | let dur = duration (fun () -> (I.pp ppf) (i.Db.image i.Db.view)) () in 137 | log "(%a) [DONE]@." pp_dur dur; 138 | close_out oc 139 | with e -> log "[FAIL]@."; close_out oc; raise e 140 | with Sys_error e -> log_msg "%s@." e; exit 1 141 | 142 | (* Image info *) 143 | 144 | let pp_image_info ppf i = 145 | let pp_comma ppf () = pp ppf ",@ " in 146 | let pp_tags ppf = function 147 | | [] -> () 148 | | ts -> pp ppf " @[<1>[%a]@]" (pp_list ~pp_sep:pp_comma pp_str) i.Db.tags 149 | in 150 | let pp_opt_text_field fn ppf = function 151 | | None -> () 152 | | Some fv -> pp ppf "%s: @[%a@]@," fn pp_text fv 153 | in 154 | pp ppf "* @[%s%a@,@," i.Db.id pp_tags i.Db.tags; 155 | pp ppf "@[%a@]@," pp_text i.Db.title; 156 | pp ppf "@[%a, %s@]@," pp_text (fst i.Db.author) (snd i.Db.author); 157 | pp_opt_text_field "note" ppf i.Db.note; 158 | pp ppf "@]" 159 | 160 | (* Command line *) 161 | 162 | let main_multiformats rname ftypes renderer = 163 | let usage = Printf.sprintf 164 | "Usage: %s [OPTION]... [ID1] [ID2]...\n\ 165 | \ Renders images of the Vg image database to %s files.\n\ 166 | \ Without any selector and ID specified renders all images.\n\ 167 | Options:" exec rname 168 | in 169 | let ftype = ref (List.hd ftypes) in 170 | let set_ftype fmt = ftype := List.find (fun (f, _) -> f = fmt) ftypes in 171 | let cmd = ref `Image_render in 172 | let set_cmd v () = cmd := v in 173 | let list () = let l = ref [] in (l, fun v -> l := v :: !l) in 174 | let ids, add_id = list () in 175 | let prefixes, add_prefix = list () in 176 | let tags, add_tag = list () in 177 | let pack = ref None in 178 | let dir = ref "/tmp" in 179 | let sout = ref false in 180 | let use_unix = ref false in 181 | let usize = ref unix_buffer_size in 182 | let nat s r v = if v > 0 then r := v else log "%s must be > 0, ignored\n" s in 183 | let options = 184 | begin match ftypes with 185 | | [] | [_] -> [] 186 | | _ -> 187 | [ "-format", Arg.Symbol (List.map fst ftypes, set_ftype), 188 | Printf.sprintf "Selects the image format (default: %s)" (fst !ftype) ] 189 | end @ [ 190 | "-dump", Arg.Unit (set_cmd `Image_dump), 191 | (str " Output a textual internal representation"); 192 | "-p", Arg.String add_prefix, 193 | " Selects any image whose id matches , repeatable"; 194 | "-t", Arg.String add_tag, 195 | " Selects any images tagged by , repeatable"; 196 | "-ids", Arg.Unit (set_cmd `List_ids), 197 | " Output the selected image ids on stdout"; 198 | "-tags", Arg.Unit (set_cmd `List_tags), 199 | " Output the tags of the selected images on stdout"; 200 | "-i", Arg.Unit (set_cmd `Image_info), 201 | " Output info about selected images on stdout"; 202 | "-pack", Arg.String (fun fn -> pack := Some fn), 203 | (str " Pack the selected images in the single (if supported)"); 204 | "-d", Arg.Set_string dir, 205 | (str "

directory in which files are output (defaults to `%s')" !dir); 206 | "-sout", Arg.Set sout, 207 | " Render to a string and output the string"; 208 | "-unix", Arg.Set use_unix, 209 | " Use Unix IO"; 210 | "-usize", Arg.Int (nat "-usize" usize), 211 | " Unix IO buffer sizes in bytes"; ] 212 | in 213 | Arg.parse (Arg.align options) add_id usage; 214 | let imgs = match !ids, !prefixes, !tags with 215 | | [], [], [] -> Db.search ~prefixes:[""] () (* all images *) 216 | | ids, prefixes, tags -> Db.search ~ids ~prefixes ~tags () 217 | in 218 | match !cmd with 219 | | `Image_render -> 220 | let renderer = renderer !ftype in 221 | let render = render !sout !use_unix !usize !dir !ftype !pack renderer in 222 | let dur = duration render imgs in 223 | log "Wrote %d images in %a.@." (List.length imgs) pp_dur dur 224 | | `Image_dump -> 225 | let dur = duration (List.iter (dump !dir (fst !ftype))) imgs in 226 | log "Wrote %d images in %a.@." (List.length imgs) pp_dur dur 227 | | `Image_info -> 228 | pp Format.std_formatter "@[%a@]@." (pp_list pp_image_info) imgs 229 | | `List_ids -> 230 | List.iter (fun i -> print_endline i.Db.id) imgs 231 | | `List_tags -> 232 | let add_tag acc t = if List.mem t acc then acc else t :: acc in 233 | let add_tags acc i = List.fold_left add_tag acc i.Db.tags in 234 | let tags = List.fold_left add_tags [] imgs in 235 | List.iter print_endline (List.sort compare tags) 236 | 237 | let main rname ftype ~pack renderer = 238 | main_multiformats rname [ftype, pack] (fun _ -> renderer) 239 | -------------------------------------------------------------------------------- /test/test_vgr_svg.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2013 The vg programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | open Gg 7 | open Vg 8 | 9 | include Db_contents 10 | 11 | let renderer dst is = 12 | Vgr.create (Vgr_svg.target ~xmp:(Test_vgr_stored.xmp is) ()) dst 13 | 14 | let () = Test_vgr_stored.main "SVG" "svg" ~pack:false renderer 15 | -------------------------------------------------------------------------------- /test/vecho.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2013 The vg programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | (* Like echo(1) but produces a PDF file on stdout *) 7 | 8 | open Gg 9 | open Vg 10 | 11 | let fold_utf_8 f acc s = (* XXX code should be rewritten without this *) 12 | let rec loop s i acc = 13 | if i >= String.length s then acc else 14 | let dec = String.get_utf_8_uchar s i in 15 | let n = Uchar.utf_decode_length dec in 16 | let i' = i + n in 17 | match Uchar.utf_decode_is_valid dec with 18 | | false -> loop s i' (f acc i (`Malformed (String.sub s i n))) 19 | | true -> loop s i' (f acc i (`Uchar (Uchar.utf_decode_uchar dec))) 20 | in 21 | loop s 0 acc 22 | 23 | let str = Printf.sprintf 24 | let otfm_err_str err = 25 | Format.fprintf Format.str_formatter "%a" Otfm.pp_error err; 26 | Format.flush_str_formatter () 27 | 28 | let string_of_file inf = 29 | try 30 | let ic = if inf = "-" then stdin else open_in_bin inf in 31 | let close ic = if inf <> "-" then close_in ic else () in 32 | let buf_size = 65536 in 33 | let b = Buffer.create buf_size in 34 | let s = Bytes.create buf_size in 35 | try 36 | while true do 37 | let c = input ic s 0 buf_size in 38 | if c = 0 then raise Exit else 39 | Buffer.add_subbytes b s 0 c 40 | done; 41 | assert false 42 | with 43 | | Exit -> close ic; Ok (Buffer.contents b) 44 | | Failure _ -> close ic; Error (str "%s: input file too large" inf) 45 | | Sys_error e -> close ic; Error (str "%s: %s" inf e) 46 | with 47 | | Sys_error e -> Error (str "%s: %s" inf e) 48 | 49 | (* Font information *) 50 | 51 | module Int = struct type t = Vg.glyph let compare = compare end 52 | module Gmap = Map.Make (Int) (* glyph maps *) 53 | module Cmap = Gmap (* uchar maps *) 54 | 55 | type otf_info = 56 | { i_otf : string; (* The font bytes. *) 57 | i_cmap : int Cmap.t; (* Maps unicode scalar values to glyphs. *) 58 | i_advs : int Gmap.t; (* Maps glyph to advances in em space. *) 59 | i_kern : int Gmap.t Gmap.t; (* Maps glyph pairs to kern adjustement. *) 60 | i_units_per_em : int; } (* Number of units per em. *) 61 | 62 | let add_adv acc g adv _ = Gmap.add g adv acc 63 | let add_cmap acc kind (u0, u1) g = 64 | let acc = ref acc in 65 | begin match kind with 66 | | `Glyph_range -> 67 | for i = 0 to (u1 - u0) do acc := Cmap.add (u0 + i) (g + i) !acc done; 68 | | `Glyph -> 69 | for u = u0 to u1 do acc := Cmap.add u g !acc done 70 | end; 71 | !acc 72 | 73 | let add_ktable acc i = 74 | (if i.Otfm.kern_dir = `H && i.Otfm.kern_kind = `Kern then `Fold else `Skip), 75 | acc 76 | 77 | let add_kpair acc g0 g1 kv = 78 | let m = try Gmap.find g0 acc with Not_found -> Gmap.empty in 79 | Gmap.add g0 (Gmap.add g1 kv m) acc 80 | 81 | let font_info font = match font with 82 | | None -> Ok ("Courier", None) 83 | | Some inf -> 84 | match string_of_file inf with 85 | | Error _ as e -> e 86 | | Ok i_otf -> 87 | let ( >>= ) x f = match x with 88 | | Error e -> Error (str "%s: %s" inf (otfm_err_str e)) 89 | | Ok v -> f v 90 | in 91 | let d = Otfm.decoder (`String i_otf) in 92 | Otfm.postscript_name d >>= fun name -> 93 | Otfm.head d >>= fun head -> 94 | Otfm.cmap d add_cmap Cmap.empty >>= fun (_, i_cmap) -> 95 | Otfm.hmtx d add_adv Gmap.empty >>= fun i_advs -> 96 | Otfm.kern d add_ktable add_kpair Gmap.empty >>= fun i_kern -> 97 | let name = match name with None -> "Unknown" | Some n -> n in 98 | let i_units_per_em = head.Otfm.head_units_per_em in 99 | Ok (name, Some { i_otf; i_cmap; i_advs; i_kern; i_units_per_em }) 100 | 101 | let get_glyph fi g = try Gmap.find g fi.i_cmap with Not_found -> 0 102 | let get_adv fi g = try Gmap.find g fi.i_advs with Not_found -> 0 103 | let get_kern fi g g' = 104 | try Gmap.find g' (Gmap.find g fi.i_kern) with Not_found -> 0 105 | 106 | (* Text layout *) 107 | 108 | let fixed_layout size text = 109 | let units_per_em = 1000. in 110 | let add_adv acc _ = function 111 | | `Malformed _ -> acc + 600 112 | | `Uchar _ -> acc + 600 (* Courier's advance *) 113 | in 114 | let len = size *. (float (fold_utf_8 add_adv 0 text)) in 115 | [], [], (len /. units_per_em) 116 | 117 | let otf_layout fi size text = 118 | let u_to_em = float fi.i_units_per_em in 119 | let rec add_glyph (gs, advs, len as acc) i = function 120 | | `Malformed _ -> add_glyph acc i (`Uchar Uchar.rep) 121 | | `Uchar u -> 122 | let g = get_glyph fi (Uchar.to_int u) in 123 | let adv = get_adv fi g in 124 | let sadv = V2.v ((size *. (float adv)) /. u_to_em) 0. in 125 | (g :: gs, sadv :: advs, len + adv) 126 | in 127 | let gs, advs, len = fold_utf_8 add_glyph ([], [], 0) text in 128 | gs, advs, ((size *. (float len)) /. u_to_em) 129 | 130 | let otf_kern_layout fi size text = 131 | let u_to_em = float fi.i_units_per_em in 132 | let rec add (prev, gs, advs, kerns as acc) i = function 133 | | `Malformed _ -> add acc i (`Uchar Uchar.rep) 134 | | `Uchar u -> 135 | let g = get_glyph fi (Uchar.to_int u) in 136 | let advs = get_adv fi g :: advs in 137 | let kerns = if prev = -1 then kerns else (get_kern fi prev g) :: kerns in 138 | (g, g :: gs, advs, kerns) 139 | in 140 | let rec advances acc len advs kerns = match advs, kerns with 141 | | adv :: advs, k :: kerns -> 142 | let adv = adv + k in 143 | let sadv = V2.v ((size *. (float adv)) /. u_to_em) 0. in 144 | advances (sadv :: acc) (len + adv) advs kerns 145 | | adv :: [], [] -> acc, len + adv 146 | | _ -> assert false 147 | in 148 | let _, gs, advs, kerns = fold_utf_8 add (-1, [], [], []) text in 149 | let advs, len = advances [] 0 (List.rev advs) (List.rev kerns) in 150 | gs, advs, ((size *. float len) /. u_to_em) 151 | 152 | (* Text rendering *) 153 | 154 | let renderable (fname, info) size kern text = 155 | let glyphs_rev, advances_rev, len = match info with 156 | | None -> fixed_layout size text 157 | | Some info when kern -> otf_kern_layout info size text 158 | | Some info -> otf_layout info size text 159 | in 160 | let glyphs, advances = List.rev glyphs_rev, List.rev advances_rev in 161 | let font = { Font.name = fname; slant = `Normal; weight = `W400; size } in 162 | let i = 163 | I.const (Color.black) |> 164 | I.cut_glyphs ~text ~advances font glyphs |> 165 | I.move V2.(0.5 * (v size size)) 166 | in 167 | let size = Size2.v (len +. size) (2. *. size) in 168 | let view = Box2.v P2.o size in 169 | `Image (size, view, i) 170 | 171 | let font_resolver = function 172 | | name, None -> Ok (fun _ -> `Fixed) 173 | | name, Some info -> 174 | match Vgr_pdf.otf_font info.i_otf with 175 | | Error _ as e -> e 176 | | Ok (`Otf _ as otf) -> Ok (fun _ -> otf) 177 | 178 | let echo font size kern msg = match font_info font with 179 | | Error _ as e -> e 180 | | Ok font_info -> 181 | match font_resolver font_info with 182 | | Error e -> Error (otfm_err_str e) 183 | | Ok font -> 184 | let renderable = renderable font_info size kern msg in 185 | let () = Out_channel.set_binary_mode stdout true in 186 | let r = Vgr.create (Vgr_pdf.target ~font ()) (`Channel stdout) in 187 | ignore (Vgr.render r renderable); 188 | ignore (Vgr.render r `End); 189 | Ok () 190 | 191 | (* Command line *) 192 | 193 | let exec = Filename.basename Sys.executable_name 194 | let main () = 195 | let usage = Printf.sprintf 196 | "Usage: %s [OPTION]... [STRING]... \n\ 197 | Writes UTF-8 encoded strings to a PDF document on stdout.\n\ 198 | Options:" exec 199 | in 200 | let font = ref "" in 201 | let size = ref 20. in 202 | let kern = ref false in 203 | let msg = Buffer.create 255 in 204 | let add_string s = Buffer.add_string msg s; Buffer.add_char msg ' ' in 205 | let options = [ 206 | "-f", (Arg.Set_string font), " FILE, specify the OpenType font file to use"; 207 | "-s", (Arg.Set_float size), " SIZE, specify the font size (in mm)"; 208 | "-k", (Arg.Set kern), " use OpenType kern table"; 209 | ] 210 | in 211 | Arg.parse (Arg.align options) add_string usage; 212 | let msg = 213 | let l = Buffer.length msg in 214 | Buffer.sub msg 0 (if l > 0 then l - 1 else 0) (* rem. last ' ' *) 215 | in 216 | let font = match !font with "" -> None | f -> Some f in 217 | match echo font !size !kern msg with 218 | | Error e -> Format.eprintf "%s: %s@." exec e; exit 1 219 | | Ok () -> exit 0 220 | 221 | let () = main () 222 | --------------------------------------------------------------------------------