├── .gitignore ├── .merlin ├── .ocp-indent ├── B0.ml ├── BRZO ├── CHANGES.md ├── DEVEL.md ├── LICENSE.md ├── README.md ├── _tags ├── doc └── index.mld ├── opam ├── pkg ├── META └── pkg.ml ├── src ├── gg.ml ├── gg.mli ├── gg.mllib ├── kit │ ├── gg__color_scheme.ml │ ├── gg__color_scheme.mli │ ├── gg__field2.ml │ ├── gg__field2.mli │ ├── gg__pgon2.ml │ ├── gg__pgon2.mli │ ├── gg__ring2.ml │ ├── gg__ring2.mli │ ├── gg_kit.ml │ ├── gg_kit.mli │ └── gg_kit.mllib └── top │ ├── gg_top.ml │ ├── gg_top.mllib │ └── gg_top_init.ml └── test ├── benchmark.ml ├── checkm.ml ├── checkm.mli ├── color_schemes.ml ├── lcmsgen.c ├── orient_p2.ml ├── pgon2_bool_steps.ml ├── pgon2_bool_tests.ml ├── pgon2_test_cases.ml ├── rgbtest.csv ├── test_color_scheme.ml ├── test_gg.ml └── test_ring2.ml /.gitignore: -------------------------------------------------------------------------------- 1 | *.install 2 | _build 3 | _b0 4 | tmp 5 | -------------------------------------------------------------------------------- /.merlin: -------------------------------------------------------------------------------- 1 | PKG b0.kit vg vg.pdf vg.htmlc brr 2 | S src/** 3 | S test 4 | B _b0/b/** -------------------------------------------------------------------------------- /.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 b0_std = B0_ocaml.libname "b0.std" 6 | let str = B0_ocaml.libname "str" 7 | let compiler_libs_toplevel = B0_ocaml.libname "compiler-libs.toplevel" 8 | 9 | let gg = B0_ocaml.libname "gg" 10 | let gg_top = B0_ocaml.libname "gg.top" 11 | let gg_kit = B0_ocaml.libname "gg.kit" 12 | 13 | (* Libraries *) 14 | 15 | let gg_lib = B0_ocaml.lib gg ~srcs:[`Dir ~/"src/"] 16 | 17 | let gg_top_lib = 18 | let srcs = [ `File ~/"src/top/gg_top.ml" ] in 19 | B0_ocaml.lib gg_top ~srcs ~requires:[compiler_libs_toplevel] 20 | 21 | let gg_kit_lib = 22 | B0_ocaml.lib gg_kit ~srcs:[`Dir ~/"src/kit"] ~requires:[gg] 23 | 24 | (* Tests *) 25 | 26 | let test ?(requires = []) = B0_ocaml.test ~requires:(b0_std :: gg :: requires) 27 | 28 | let test_gg = 29 | let srcs = [ `File ~/"test/checkm.mli"; `File ~/"test/checkm.ml" ] in 30 | let requires = [str] in 31 | test ~/"test/test_gg.ml" ~srcs ~requires 32 | 33 | let test_ring2 = test ~/"test/test_ring2.ml" ~requires:[gg_kit] 34 | let test_color_scheme = 35 | test ~/"test/test_color_scheme.ml" ~long:true ~requires:[gg_kit] 36 | 37 | 38 | (* N.B. Unless vg is in the build, those tests with vg needs to be 39 | build with `-x gg` otherwise we get inconsistent assumptions. See 40 | the also the pgon2_bool_tests pack. *) 41 | 42 | let vg = B0_ocaml.libname "vg" 43 | let vg_htmlc = B0_ocaml.libname "vg.htmlc" 44 | let vg_pdf = B0_ocaml.libname "vg.pdf" 45 | let brr = B0_ocaml.libname "brr" 46 | 47 | let pgon2_bool_steps = 48 | let doc = "Pgon2 boolean operations step debugger" in 49 | let srcs = 50 | [`Dir ~/"src_kit"; 51 | `File ~/"test/pgon2_test_cases.ml"; 52 | `File ~/"test/pgon2_bool_steps.ml";] 53 | in 54 | let requires = [gg; vg; vg_htmlc; brr] in 55 | let assets_root = ~/"test" in 56 | let meta = 57 | B0_meta.empty 58 | |> ~~ B0_jsoo.compilation_mode `Separate 59 | |> ~~ B0_jsoo.source_map (Some `Inline) 60 | in 61 | B0_jsoo.html_page "pgon2_bool_steps" ~assets_root ~requires ~doc ~srcs ~meta 62 | 63 | let pgon2_bool_tests = 64 | let doc = "Pgon2 boolean operations tests" in 65 | let srcs = 66 | [ `Dir ~/"src_kit"; 67 | `File ~/"test/pgon2_test_cases.ml"; 68 | `File ~/"test/pgon2_bool_tests.ml";] 69 | in 70 | let requires = [b0_std; gg; vg; vg_pdf] in 71 | let meta = B0_meta.(empty |> tag test) in 72 | B0_ocaml.exe "pgon2_bool_tests" ~srcs ~doc ~meta ~requires 73 | 74 | let viz_orient = 75 | let doc = "Orientation predicate visualization" in 76 | let srcs = [ `File ~/"test/orient_p2.ml" ] in 77 | let requires = [gg; brr] in 78 | let meta = 79 | B0_meta.empty 80 | |> ~~ B0_jsoo.compilation_mode `Separate 81 | |> ~~ B0_jsoo.source_map (Some `Inline) 82 | in 83 | B0_jsoo.html_page "orient_p2" ~requires ~doc ~srcs ~meta 84 | 85 | let color_schemes = 86 | let doc = "Color schemes visualization"in 87 | let srcs = [`File ~/"test/color_scheme.ml"] in 88 | let requires = [gg; gg_kit; brr; vg; vg_htmlc] in 89 | let meta = 90 | B0_meta.empty 91 | |> ~~ B0_jsoo.compilation_mode `Separate 92 | |> ~~ B0_jsoo.source_map (Some `Inline) 93 | in 94 | B0_jsoo.html_page "color_schemes" ~requires ~doc ~srcs ~meta 95 | 96 | (* Packs *) 97 | 98 | let pgon_test_pack = 99 | (* We use a locked pack so that we compile against the installed gg 100 | otherwise we compile gg and we get inconsistent assumptions with 101 | installed vg. *) 102 | let meta = B0_meta.(empty |> tag test) in 103 | let doc = "Pgon2 boolean operations visual testing" in 104 | B0_pack.make "pgon2_bool_tests" ~doc ~meta ~locked:true @@ 105 | [pgon2_bool_tests; pgon2_bool_steps] 106 | 107 | let default = 108 | let meta = 109 | B0_meta.empty 110 | |> ~~ B0_meta.authors ["The gg programmers"] 111 | |> ~~ B0_meta.maintainers ["Daniel Bünzli "] 112 | |> ~~ B0_meta.homepage "https://erratique.ch/software/gg" 113 | |> ~~ B0_meta.online_doc "https://erratique.ch/software/gg/doc/" 114 | |> ~~ B0_meta.licenses ["ISC"; "Apache-2.0"] 115 | |> ~~ B0_meta.repo "git+https://erratique.ch/repos/gg.git" 116 | |> ~~ B0_meta.issues "https://github.com/dbuenzli/gg/issues" 117 | |> ~~ B0_meta.description_tags 118 | ["matrix"; "vector"; "color"; "data-structure"; "graphics"; 119 | "org:erratique"] 120 | |> ~~ B0_opam.depends 121 | [ "ocaml", {|>= "4.08.0"|}; 122 | "ocamlfind", {|build|}; 123 | "ocamlbuild", {|build|}; 124 | "topkg", {|build & >= "1.0.3"|}; 125 | "brr", {|with-test|}; 126 | "vg", {|with-test|}; 127 | ] 128 | |> ~~ B0_opam.build 129 | {|[["ocaml" "pkg/pkg.ml" "build" "--dev-pkg" "%{dev}%"]]|} 130 | |> B0_meta.tag B0_opam.tag 131 | in 132 | B0_pack.make "default" ~doc:"gg package" ~meta ~locked:true @@ 133 | [ gg_lib; gg_kit_lib; gg_top_lib; test_gg; test_ring2; 134 | test_color_scheme; viz_orient] 135 | -------------------------------------------------------------------------------- /BRZO: -------------------------------------------------------------------------------- 1 | (srcs-x pkg test tmp) -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | 2 | - Add `Box2.aspect`. 3 | - Add `Color.{to,of}_{oklab,oklch}`. 4 | - Add `P2.orient_fast`. 5 | - Add `P2.seg_inter`. 6 | - Add `Float.seg_inter`. 7 | - Add `Box{1,2,3}.outset`. 8 | 9 | 10 | - Add `Gg_kit.Color_scheme`. Note that some of the color schemes 11 | are licensed under the Apache 2.0 and CC0 licenses. 12 | - Add `Gg_kit.Ring2`, a module to represent linear rings. 13 | - Add `Gg_kit.Pgon2`, a module to represent polygons 14 | and compute their boolean intersections. 15 | - Add `Gg_kit.Field2`, a module to represent vector fields 16 | and compute their isolines. 17 | 18 | v1.0.0 2022-02-15 La Forclaz (VS) 19 | -------------------------------- 20 | 21 | - Require OCaml 4.08. 22 | 23 | - Handle `Pervasives`'s deprecation (and thus provide OCaml 24 | 5.00 support). 25 | 26 | - Drop dependency on `bigarray`'s ocamlfind package (and thus 27 | provide OCaml 5.00 support). 28 | 29 | - Change the semantics of `Box{1,2,3}.inset`. Rather than return the 30 | empty box when the size in a dimension `i` become negative, clamp it 31 | to `0` and use the `i`th coordinate of the mid point of the box for 32 | the `i`th coordinate of the resulting box's origin. This means that 33 | insetting boxes with large values eventually degenerates to the mid 34 | point of a box instead of the empty box. This avoids losing a box's 35 | location when one grows and shrinks them arbitrarily, e.g. in 36 | reaction to user input. Thanks to Michel Schinz for suggesting this 37 | better semantics. 38 | 39 | - Change `Gg.Float.pp` hexadecimal notation renderer to use the 40 | built-in `"%h"` string introduced in OCaml 4.03.0. Nans, zeros and 41 | infinities will render differently. Use the deprecated 42 | `Gg.Float.pp_legacy` if you need to recover the old hex rendering. 43 | 44 | - The `Gg.Float` module now includes `Stdlib.Float` (#19). Some values 45 | initially implemented in `Gg.Float` now use `Stdlib.Float`'s 46 | definition or are deprecated in favour of corresponding 47 | functionality named differently. Implementations may differ but this 48 | shouldn't matter most of the time except for the first three items 49 | in this list: 50 | 51 | * **WARNING** `Gg.Float.equal` is deleted in favour of `Stdlib.Float.equal` 52 | The implemention differs, it moves from `x = y` 53 | to `compare x y = 0` which differs on nan values. 54 | `Stdlib.Float.equal` treats them as equal `Gg.Float.equal` does not. 55 | * **WARNING** `Gg.Float.round` is deleted and becomes `Stdlib.Float.round`. 56 | The implementation and behaviour on negative numbers differs. 57 | `Gg.Float.round` always rounded towards positive infinity on ties (`-2.` 58 | on `-2.5`). `Stdlib.Float.round`s away from zero on ties (`-3.` on `-2.5`). 59 | * **WARNING** `Gg.Float.round_to_int` is affected by the new `round` 60 | implementation (see previous point). 61 | * `Gg.Float.compare` is deleted and becomes `Stdlib.Float.compare` 62 | (same implementation). 63 | * `Gg.Float.pi` is deleted and becomes `Stdlib.Float.pi`, the bit pattern 64 | of the value is unchanged. 65 | * `Gg.Float.is_inf` is implemented by `Stdlib.Float.is_infinite` 66 | and deprecated in favour of it (different implementation). 67 | * `Gg.Float.is_int` is implemented by `Stdlib.Float.is_integer` 68 | and deprecated in favour of it (different implementation). 69 | * `Gg.Float.is_nan` is deleted and becomes `Stdlib.Float.is_nan` 70 | (same implementation) 71 | * `Gg.Float.fmax` is implemented by `Stdlib.Float.max_num` and 72 | deprecated in favour of it. The result of `Gg.Float.fmax (-0.) 73 | (+0.)` is changed, it returns `+0.` instead of `-0.`. 74 | * `Gg.Float.fmin` is implemented by `Stdlib.Float.min_num` and 75 | deprecated in favour of it. The result of `Gg.Float.fmin (+0.) 76 | (-0.)` is changed, it returns `-0.` instead of `+0.`. 77 | * `Gg.Float.sign_bit` is deleted and becomes `Stdlib.Float.sign_bit` 78 | (different implementation). 79 | * `Gg.Float.succ` is deleted and becomes `Stdlib.Float.succ` 80 | (different implementation). 81 | * `Gg.Float.pred` is deleted and becomes `Stdlib.Float.pred` 82 | (different implementation). 83 | * `Gg.Float.nan` is renamed to `Gg.Float.nan_with_payload` 84 | to leave room for `Stdlib.Float.nan`'s constant. 85 | 86 | 87 | v0.9.3 2018-10-23 Zagreb 88 | ------------------------ 89 | 90 | - Add `Color.to_srgbi` (inverse of `Color.v_srgbi`). Thanks to 91 | Christophe Troestler for the patch. 92 | - Add missing constraints on `Float.{is_nan,equal,compare}`. Polymorphic 93 | equality was being used. Thanks to Christophe Troestler for the report 94 | (#17). 95 | - Fix bug in `Gg.M3.rot2 ?pt:(Some _)` (#18). 96 | 97 | v0.9.2 2017-01-24 La Forclaz (VS) 98 | --------------------------------- 99 | 100 | - Add `Box{1,2,3}.add_pt`. Thanks to Christophe Troestler for the suggestion. 101 | - `V{2,3,4}.norm` avoid {under,over}flows. Thanks to Christophe Troestler for 102 | the report and guidance. 103 | - Fix `Size.of_w`. Thanks to @rand00 for the report and the fix. 104 | - Safe-string support. 105 | - Build depend on topkg. 106 | - Relicense from BSD3 to ISC. 107 | 108 | v0.9.1 2015-08-14 Cambridge (UK) 109 | -------------------------------- 110 | 111 | - Fix `Box1.pp` and add to toplevel support. 112 | - Fix broken `Box{1,2,3}.subset` functions. Thanks to Armaël Guéneau 113 | for the report. 114 | - Change toplevel support scheme, `#require "gg"` no longer automatically 115 | opens `Gg` and installs printers. You now have to `#require "gg.top"` for 116 | this to happen. 117 | 118 | 119 | v0.9.0 2014-08-23 Cambridge (UK) 120 | -------------------------------- 121 | 122 | - Fix toplevel printer installation. 123 | - Use package builder topkg for distribution. 124 | - Add `Gg.Ba` (experimental). Convenience module for linear 1D bigarrays. 125 | The library now depends on Bigarrays. 126 | - Many changes and fixes to the experimental `Gg.Raster` module. 127 | - Removed `to_string` functions, they were not thread safe and we 128 | now have `Format.asprintf` which can be used with the pretty printers. 129 | - Add an optional argument to `M3.rot2` to specify a center for the rotation. 130 | - Optimize `M{2,3,4}.mul` on `M{2,3,4}.id` arguments. 131 | - Add `M4.{move2,rot2,scale2,rigid2}` 132 | - Rename `M4.{ortho,persp}`, replace `~bottom` by `~bot`. 133 | - Add `Size1` module for sizes in 1D space. 134 | - Add `Box1` module for 1D axis-aligned boxes (closed intervals). 135 | - Add `Size2.{aspect,of_h,of_w}` functions. 136 | - Add `Box2.{bm_pt,ml_pt,mm_pt,mr_pt,tm_pt}` for accessing middle points on 137 | the sides. 138 | - Rename `Box2.{bottom,top}_{left,right}` to `Box2.{b,t}{l,r}_pt`. 139 | - Add `Box3.{fbl,fbr,ftl,ftr,nbl,nbr,ntl,ntr}` corner accessors. 140 | - Fix a bug in `Box3.inset`, new size was incorrectly computed. 141 | 142 | The following functions were renamed so that each module uses the same 143 | name for the same transform. Previously we had e.g. `M3.scale` and 144 | `M4.scale3` (3D) and `M4.scale` (4D) which is confusing and 145 | inconvenient when one wants to switch from one matrix to the other. 146 | 147 | - Rename `M2.{rot,scale}` to `M2.{rot2,scale2}`. 148 | - Rename `M3.{move,rot,rigid,srigid}` to `M3.{move2,rot2,rigid2,srigid2}`. 149 | - Rename `M3.{rot_{map,axis,zyx},scale}` to `M3.{rot3_{map,axis,zyx},scale3}`. 150 | - Rename `M4.{move,rot_{map,axis,zyx},scale,rigid,rigidq,srigid,srigidq}` to 151 | `M3.{move3,rot3_{map,axis,zyx},scale,rigid3,rigid3q,srigid3,srigid3q}` 152 | - Rename `M4.scale` to `M4.scale4` 153 | - Rename `M4.{rot_{map,axis,zyx},to_rot_{axis,zyx}` to 154 | `M4.{rot3_{map,axis,zyx},to_rot3_{axis,zyx}`. 155 | 156 | v0.8.0 2013-09-24 Lausanne 157 | -------------------------- 158 | 159 | First release. 160 | Part of the work was sponsored by Citrix Systems R&D and OCaml Labs. 161 | -------------------------------------------------------------------------------- /DEVEL.md: -------------------------------------------------------------------------------- 1 | # Tests 2 | 3 | A few tests need `vg` and `brr`: 4 | 5 | opam install vg brr 6 | 7 | Or `b0 file gather` them with this repo. 8 | 9 | # Test and debug Pgon2 boolean ops 10 | 11 | We need `vg`, but the latter depends on `gg`, so unless `vg` is part 12 | of the build we need to exclude `gg` when we build otherwise we get 13 | inconsistent assumptions. Either: 14 | 15 | b0 -x gg -- pgon2_bool_tests 16 | b0 -x gg -- pgon2_bool_steps 17 | 18 | or the `pgon_bool_tests` is a locked pack which has the tests but not `gg`: 19 | 20 | b0 -p pgon2_bool_tests -- … 21 | 22 | 23 | 24 | 25 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | # Gg copyrights 2 | 3 | The gg project is covered by the following copyrights. 4 | 5 | * Some qualitative color schemes in [`src_kit/gg__color_scheme.ml`][scheme] are 6 | covered by [this Apache 2.0 license](#colorbrewer). 7 | * The turbo color scheme in [`src_kit/gg__color_scheme.ml`][scheme] is 8 | covered by [this Apache 2.0 license](#turbo) 9 | * The magma, inferno, plasma and viridis color schemes are 10 | covered by [this CC0](#viridis) license. 11 | 12 | 13 | [scheme]: src_kit/gg__color_scheme 14 | 15 | All the rest is covered by the following ISC license. 16 | 17 | ``` 18 | Copyright (c) 2013 The gg programmers 19 | 20 | Permission to use, copy, modify, and/or distribute this software for any 21 | purpose with or without fee is hereby granted, provided that the above 22 | copyright notice and this permission notice appear in all copies. 23 | 24 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 25 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 26 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 27 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 28 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 29 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 30 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 31 | ``` 32 | 33 | ## Colorbrewer 34 | 35 | ``` 36 | Copyright 2002 37 | Cynthia Brewer, Mark Harrower, and The Pennsylvania State University 38 | 39 | Licensed under the Apache License, Version 2.0 (the "License"); 40 | you may not use this file except in compliance with the License. 41 | You may obtain a copy of the License at 42 | 43 | http://www.apache.org/licenses/LICENSE-2.0 44 | 45 | Unless required by applicable law or agreed to in writing, software 46 | distributed under the License is distributed on an "AS IS" BASIS, 47 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 48 | See the License for the specific language governing permissions and 49 | limitations under the License. 50 | ``` 51 | 52 | ## Turbo 53 | 54 | ``` 55 | Copyright 2019 Google LLC. 56 | 57 | Licensed under the Apache License, Version 2.0 (the "License"); 58 | you may not use this file except in compliance with the License. 59 | You may obtain a copy of the License at 60 | 61 | http://www.apache.org/licenses/LICENSE-2.0 62 | 63 | Unless required by applicable law or agreed to in writing, software 64 | distributed under the License is distributed on an "AS IS" BASIS, 65 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 66 | See the License for the specific language governing permissions and 67 | limitations under the License. 68 | ``` 69 | 70 | ## Viridis 71 | 72 | ``` 73 | Nathaniel Smith & Stefan van der Walt & Eric Firing. 74 | 75 | Creative Commons Legal Code 76 | 77 | CC0 1.0 Universal 78 | 79 | CREATIVE COMMONS CORPORATION IS NOT A LAW FIRM AND DOES NOT PROVIDE 80 | LEGAL SERVICES. DISTRIBUTION OF THIS DOCUMENT DOES NOT CREATE AN 81 | ATTORNEY-CLIENT RELATIONSHIP. CREATIVE COMMONS PROVIDES THIS 82 | INFORMATION ON AN "AS-IS" BASIS. CREATIVE COMMONS MAKES NO WARRANTIES 83 | REGARDING THE USE OF THIS DOCUMENT OR THE INFORMATION OR WORKS 84 | PROVIDED HEREUNDER, AND DISCLAIMS LIABILITY FOR DAMAGES RESULTING FROM 85 | THE USE OF THIS DOCUMENT OR THE INFORMATION OR WORKS PROVIDED 86 | HEREUNDER. 87 | 88 | Statement of Purpose 89 | 90 | The laws of most jurisdictions throughout the world automatically confer 91 | exclusive Copyright and Related Rights (defined below) upon the creator 92 | and subsequent owner(s) (each and all, an "owner") of an original work of 93 | authorship and/or a database (each, a "Work"). 94 | 95 | Certain owners wish to permanently relinquish those rights to a Work for 96 | the purpose of contributing to a commons of creative, cultural and 97 | scientific works ("Commons") that the public can reliably and without fear 98 | of later claims of infringement build upon, modify, incorporate in other 99 | works, reuse and redistribute as freely as possible in any form whatsoever 100 | and for any purposes, including without limitation commercial purposes. 101 | These owners may contribute to the Commons to promote the ideal of a free 102 | culture and the further production of creative, cultural and scientific 103 | works, or to gain reputation or greater distribution for their Work in 104 | part through the use and efforts of others. 105 | 106 | For these and/or other purposes and motivations, and without any 107 | expectation of additional consideration or compensation, the person 108 | associating CC0 with a Work (the "Affirmer"), to the extent that he or she 109 | is an owner of Copyright and Related Rights in the Work, voluntarily 110 | elects to apply CC0 to the Work and publicly distribute the Work under its 111 | terms, with knowledge of his or her Copyright and Related Rights in the 112 | Work and the meaning and intended legal effect of CC0 on those rights. 113 | 114 | 1. Copyright and Related Rights. A Work made available under CC0 may be 115 | protected by copyright and related or neighboring rights ("Copyright and 116 | Related Rights"). Copyright and Related Rights include, but are not 117 | limited to, the following: 118 | 119 | i. the right to reproduce, adapt, distribute, perform, display, 120 | communicate, and translate a Work; 121 | ii. moral rights retained by the original author(s) and/or performer(s); 122 | iii. publicity and privacy rights pertaining to a person's image or 123 | likeness depicted in a Work; 124 | iv. rights protecting against unfair competition in regards to a Work, 125 | subject to the limitations in paragraph 4(a), below; 126 | v. rights protecting the extraction, dissemination, use and reuse of data 127 | in a Work; 128 | vi. database rights (such as those arising under Directive 96/9/EC of the 129 | European Parliament and of the Council of 11 March 1996 on the legal 130 | protection of databases, and under any national implementation 131 | thereof, including any amended or successor version of such 132 | directive); and 133 | vii. other similar, equivalent or corresponding rights throughout the 134 | world based on applicable law or treaty, and any national 135 | implementations thereof. 136 | 137 | 2. Waiver. To the greatest extent permitted by, but not in contravention 138 | of, applicable law, Affirmer hereby overtly, fully, permanently, 139 | irrevocably and unconditionally waives, abandons, and surrenders all of 140 | Affirmer's Copyright and Related Rights and associated claims and causes 141 | of action, whether now known or unknown (including existing as well as 142 | future claims and causes of action), in the Work (i) in all territories 143 | worldwide, (ii) for the maximum duration provided by applicable law or 144 | treaty (including future time extensions), (iii) in any current or future 145 | medium and for any number of copies, and (iv) for any purpose whatsoever, 146 | including without limitation commercial, advertising or promotional 147 | purposes (the "Waiver"). Affirmer makes the Waiver for the benefit of each 148 | member of the public at large and to the detriment of Affirmer's heirs and 149 | successors, fully intending that such Waiver shall not be subject to 150 | revocation, rescission, cancellation, termination, or any other legal or 151 | equitable action to disrupt the quiet enjoyment of the Work by the public 152 | as contemplated by Affirmer's express Statement of Purpose. 153 | 154 | 3. Public License Fallback. Should any part of the Waiver for any reason 155 | be judged legally invalid or ineffective under applicable law, then the 156 | Waiver shall be preserved to the maximum extent permitted taking into 157 | account Affirmer's express Statement of Purpose. In addition, to the 158 | extent the Waiver is so judged Affirmer hereby grants to each affected 159 | person a royalty-free, non transferable, non sublicensable, non exclusive, 160 | irrevocable and unconditional license to exercise Affirmer's Copyright and 161 | Related Rights in the Work (i) in all territories worldwide, (ii) for the 162 | maximum duration provided by applicable law or treaty (including future 163 | time extensions), (iii) in any current or future medium and for any number 164 | of copies, and (iv) for any purpose whatsoever, including without 165 | limitation commercial, advertising or promotional purposes (the 166 | "License"). The License shall be deemed effective as of the date CC0 was 167 | applied by Affirmer to the Work. Should any part of the License for any 168 | reason be judged legally invalid or ineffective under applicable law, such 169 | partial invalidity or ineffectiveness shall not invalidate the remainder 170 | of the License, and in such case Affirmer hereby affirms that he or she 171 | will not (i) exercise any of his or her remaining Copyright and Related 172 | Rights in the Work or (ii) assert any associated claims and causes of 173 | action with respect to the Work, in either case contrary to Affirmer's 174 | express Statement of Purpose. 175 | 176 | 4. Limitations and Disclaimers. 177 | 178 | a. No trademark or patent rights held by Affirmer are waived, abandoned, 179 | surrendered, licensed or otherwise affected by this document. 180 | b. Affirmer offers the Work as-is and makes no representations or 181 | warranties of any kind concerning the Work, express, implied, 182 | statutory or otherwise, including without limitation warranties of 183 | title, merchantability, fitness for a particular purpose, non 184 | infringement, or the absence of latent or other defects, accuracy, or 185 | the present or absence of errors, whether or not discoverable, all to 186 | the greatest extent permissible under applicable law. 187 | c. Affirmer disclaims responsibility for clearing rights of other persons 188 | that may apply to the Work or any use thereof, including without 189 | limitation any person's Copyright and Related Rights in the Work. 190 | Further, Affirmer disclaims responsibility for obtaining any necessary 191 | consents, permissions or other rights required for any use of the 192 | Work. 193 | d. Affirmer understands and acknowledges that Creative Commons is not a 194 | party to this document and has no duty or obligation with respect to 195 | this CC0 or use of the Work. 196 | ``` 197 | 198 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Gg — Basic types and tools for computer graphics in OCaml 2 | ========================================================= 3 | %%VERSION%% 4 | 5 | Gg provides basic types for computer graphics. It defines types and 6 | functions for floats, vectors, points, sizes, matrices, quaternions, 7 | axis-aligned boxes, colors, color spaces, and raster data. 8 | 9 | On top of this the Gg_kit library provides a few more tools and 10 | algorithms for working with geometry and graphics. 11 | 12 | Gg and Gg_kit have no dependencies. Gg is distributed under the ISC 13 | license. Gg_kit is distributed under the ISC license and some color 14 | schemes are distributed under the Apache 2.0 and CC0 licenses. 15 | 16 | Home page: 17 | 18 | # Installation 19 | 20 | Gg can be installed with `opam`: 21 | 22 | opam install gg 23 | 24 | If you don't use `opam` consult the [`opam`](opam) file for build 25 | instructions and a complete specification of the dependencies. 26 | 27 | # Documentation 28 | 29 | The documentation can be consulted [online] or via `odig doc gg`. 30 | 31 | Questions are welcome but better asked on the [OCaml forum] than on 32 | the issue tracker. 33 | 34 | A few basic sample programs can be found in the [`test`](test/) 35 | directory. 36 | 37 | [online]: https://erratique.ch/software/gg 38 | [OCaml forum]: https://discuss.ocaml.org/ 39 | 40 | -------------------------------------------------------------------------------- /_tags: -------------------------------------------------------------------------------- 1 | true : bin_annot, safe_string 2 | 3 | <_b0> : -traverse 4 | : include 5 | : include 6 | 7 | : no_alias_deps 8 | : package(compiler-libs.toplevel) 9 | -------------------------------------------------------------------------------- /doc/index.mld: -------------------------------------------------------------------------------- 1 | {0 Gg {%html: %%VERSION%%%}} 2 | 3 | Gg provides basic types for computer graphics. It defines types and 4 | functions for floats, vectors, points, sizes, matrices, quaternions, 5 | axis-aligned boxes, colors, color spaces, and raster data. 6 | 7 | The {!Gg_kit} module provide a few more tools. 8 | 9 | {!modules: 10 | Gg 11 | Gg_kit 12 | } 13 | -------------------------------------------------------------------------------- /opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | name: "gg" 3 | synopsis: "Basic types and tools for computer graphics in OCaml" 4 | description: """\ 5 | Gg provides basic types for computer graphics. It defines types and 6 | functions for floats, vectors, points, sizes, matrices, quaternions, 7 | axis-aligned boxes, colors, color spaces, and raster data. 8 | 9 | On top of this the Gg_kit library provides a few more tools and 10 | algorithms for working with geometry and graphics. 11 | 12 | Gg and Gg_kit have no dependencies. Gg is distributed under the ISC 13 | license. Gg_kit is distributed under the ISC license and some color 14 | schemes are distributed under the Apache 2.0 and CC0 licenses. 15 | 16 | Home page: """ 17 | maintainer: "Daniel Bünzli " 18 | authors: "The gg programmers" 19 | license: ["ISC" "Apache-2.0"] 20 | tags: ["matrix" "vector" "color" "data-structure" "graphics" "org:erratique"] 21 | homepage: "https://erratique.ch/software/gg" 22 | doc: "https://erratique.ch/software/gg/doc/" 23 | bug-reports: "https://github.com/dbuenzli/gg/issues" 24 | depends: [ 25 | "ocaml" {>= "4.08.0"} 26 | "ocamlfind" {build} 27 | "ocamlbuild" {build} 28 | "topkg" {build & >= "1.0.3"} 29 | "brr" {with-test} 30 | "vg" {with-test} 31 | ] 32 | build: ["ocaml" "pkg/pkg.ml" "build" "--dev-pkg" "%{dev}%"] 33 | dev-repo: "git+https://erratique.ch/repos/gg.git" 34 | -------------------------------------------------------------------------------- /pkg/META: -------------------------------------------------------------------------------- 1 | version = "%%VERSION_NUM%%" 2 | description = "Basic types for computer graphics in OCaml" 3 | requires = "" 4 | archive(byte) = "gg.cma" 5 | archive(native) = "gg.cmxa" 6 | plugin(byte) = "gg.cma" 7 | plugin(native) = "gg.cmxs" 8 | 9 | package "top" ( 10 | version = "%%VERSION_NUM%%" 11 | description = "Gg toplevel support" 12 | requires = "gg" 13 | archive(byte) = "gg_top.cma" 14 | archive(native) = "gg_top.cmxa" 15 | plugin(byte) = "gg_top.cma" 16 | plugin(native) = "gg_top.cmxs" 17 | exists_if = "gg_top.cma" 18 | ) 19 | 20 | package "kit" ( 21 | version = "%%VERSION_NUM%%" 22 | description = "Gg toolkit" 23 | requires = "gg" 24 | directory = "kit" 25 | archive(byte) = "gg_kit.cma" 26 | archive(native) = "gg_kit.cmxa" 27 | plugin(byte) = "gg_kit.cma" 28 | plugin(native) = "gg_kit.cmxs" 29 | exists_if = "gg_kit.cma" 30 | ) 31 | -------------------------------------------------------------------------------- /pkg/pkg.ml: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env ocaml 2 | #use "topfind" 3 | #require "topkg" 4 | open Topkg 5 | 6 | let () = 7 | Pkg.describe "gg" @@ fun c -> 8 | Ok [ Pkg.mllib "src/gg.mllib"; 9 | Pkg.mllib ~api:[] "src/top/gg_top.mllib" ~dst_dir:"top"; 10 | Pkg.lib "src/top/gg_top_init.ml" ~dst:"top/gg_top_init.ml"; 11 | Pkg.mllib "src/kit/gg_kit.mllib" ~dst_dir:"kit"; 12 | Pkg.doc "doc/index.mld" ~dst:"odoc-pages/index.mld"; ] 13 | -------------------------------------------------------------------------------- /src/gg.mllib: -------------------------------------------------------------------------------- 1 | Gg -------------------------------------------------------------------------------- /src/kit/gg__color_scheme.mli: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2013 The gg programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | [@@@alert unstable 7 | "This interface may change in incompatible ways in the future."] 8 | 9 | (** Color schemes. 10 | 11 | This module provides functions to generate continuous and discrete 12 | color schemes that map quantitative or qualitative data to colors 13 | with good perceptual properties. *) 14 | 15 | (** {1:schemes Schemes} *) 16 | 17 | type continuous = float -> Gg.color 18 | (** The type for continuous schemes. A continuous scheme maps 19 | the unit interval \[[0.];[1.]\] to colors. 20 | Values outside the interval yield undefined results. *) 21 | 22 | type discrete = int -> Gg.color 23 | (** The type for discrete schemes. A discrete scheme maps an integer 24 | interval \[[0];[max]\] to colors, with [max] depending on the scheme. 25 | Values outside the interval raise [Invalid_argument]. *) 26 | 27 | (** {1:sequential Sequential} 28 | 29 | Sequential schemes are for ordered scalar data. *) 30 | 31 | val sequential_wijffelaars : 32 | ?a:float -> ?w:float -> ?s:float -> ?b:float -> ?c:float -> h:float -> 33 | unit -> continuous 34 | (** [seq_wijffelaars ~a ~w ~s ~b ~c ~h ()] is a sequential scheme 35 | where [0.] is the darkest color and [1.] the lightest. The 36 | parameters are: 37 | {ul 38 | {- [h] in \[[0;2pi]\] the main hue, the overall color.} 39 | {- [w] in \[[0;1]\] is the hue warmth for a multi-hue scheme, 40 | defaults to [0] (single-hue scheme). Augmenting [w] adds 41 | yellow which makes the scheme warmer.} 42 | {- [s] in \[[0;1]\] is saturation, the overall colorfullness, 43 | defaults to [0.6].} 44 | {- [b] in \[[0;1]\] is brightness, the overall lightness, defaults to 45 | [0.75].} 46 | {- [c] in \[[0;1]\] is contrast, the lightness difference 47 | between the darkest and the ligthest colors of the scheme, 48 | defaults to [0.88].} 49 | {- [a] is the alpha component, defaults to [1.].}} 50 | 51 | {b Note.} For equal [b], [c] and [w = 0], sequential schemes 52 | with different hues [h] have the same lightness. This can be 53 | used to generate multiple sequential schemes for multivariate 54 | data. 55 | 56 | This implements the sequential schemes described by 57 | {{:http://dx.doi.org/10.1111/j.1467-8659.2008.01203.x} 58 | M. Wijffelaars et al.}. *) 59 | 60 | val sequential_wijffelaars' : 61 | ?a:float -> ?w:float -> ?s:float -> ?b:float -> ?c:float -> h:float -> 62 | size:int -> unit -> discrete 63 | (** [sequential_wijffelaars' ~a ~w ~s ~b ~c ~h ~size] is like 64 | {!sequential_wijffelaars} except it returns a discrete sequential 65 | scheme with [size] colors and [c] defaults to [min 0.88 (0.34 66 | +. 0.06. * n)]. *) 67 | 68 | (** {2:sequential_multi Multihue} *) 69 | 70 | val sequential_turbo : ?a:float -> unit -> continuous 71 | (** [sequential_turbo ()] is the 72 | {{:https://ai.googleblog.com/2019/08/turbo-improved-rainbow-colormap-for.html} 73 | turbo} sequential scheme by Anton Mikhailov with alpha component 74 | [a] (defaults to [1.]). *) 75 | 76 | val sequential_magma : ?a:float -> unit -> continuous 77 | (** [sequential_magma ()] is the 78 | {{:https://bids.github.io/colormap/}plasma} color map 79 | by Stéfan van der Walt and Nathaniel Smith. with alpha component 80 | [a] (defaults to [1.]). *) 81 | 82 | val sequential_inferno : ?a:float -> unit -> continuous 83 | (** [sequential_inferno ()] is the 84 | {{:https://bids.github.io/colormap/}plasma} color map 85 | by Stéfan van der Walt and Nathaniel Smith. with alpha component 86 | [a] (defaults to [1.]). *) 87 | 88 | val sequential_plasma : ?a:float -> unit -> continuous 89 | (** [sequential_viridis ()] is the 90 | {{:https://bids.github.io/colormap/}plasma} color map 91 | by Stéfan van der Walt and Nathaniel Smith. with alpha component 92 | [a] (defaults to [1.]). *) 93 | 94 | val sequential_viridis : ?a:float -> unit -> continuous 95 | (** [sequential_viridis ()] is the 96 | {{:https://bids.github.io/colormap/}viridis} color map 97 | by Stéfan van der Walt, Nathaniel Smith and Eric Firing with alpha component 98 | [a] (defaults to [1.]). *) 99 | 100 | (** {1:diverging Diverging} 101 | 102 | Diverging schemes are for ordered scalar data with a defined 103 | midpoint, like zero or the data average. *) 104 | 105 | val diverging_wijffelaars : 106 | ?a:float -> ?w:float -> ?s:float -> ?b:float -> ?c:float -> 107 | ?m:float -> h0:float -> h1:float -> unit -> continuous 108 | (** [diverging_wijffelaars ~a ~w ~s ~b ~c ~m ~h0 ~h1 ()] is a 109 | diverging scheme with [0.] returning the darkest color 110 | of [h0], and [1.] the darkest color of [h1]. 111 | {ul 112 | {- [h0] in \[[0;2pi]\] is the hue, the overall color for lower values.} 113 | {- [h1] in \[[0;2pi]\] is the hue, the overall color for higher values.} 114 | {- [w] in \[[0;1]\] is the hue warmth for a multi-hue scheme, 115 | defaults to [0] (single-hue scheme). Augmenting [w] adds 116 | yellow which makes the scheme warmer.} 117 | {- [s] in \[[0;1]\] is saturation, the overall colorfullness, 118 | defaults to [0.6].} 119 | {- [b] in \[[0;1]\] is brightness, the overall lightness, defaults to 120 | [0.75].} 121 | {- [c] in \[[0;1]\] is contrast, the lightness difference 122 | between the darkest and the ligthest colors of the scheme, 123 | defaults to [0.88].} 124 | {- [m] is the mid point position, defaults to [0.5].} 125 | {- [a] is the alpha component, defaults to [1.].}} 126 | 127 | This implements the diverging schemes described by 128 | {{:http://dx.doi.org/10.1111/j.1467-8659.2008.01203.x} 129 | M. Wijffelaars et al.}. *) 130 | 131 | val diverging_wijffelaars' : 132 | ?a:float -> ?w:float -> ?s:float -> ?b:float -> ?c:float -> ?m:float -> 133 | h0:float -> h1:float -> size:int -> unit -> discrete 134 | (** [diverging_wijffelaars'] is like {!diverging_wijffelaars} 135 | except it returns a discrete diverging scheme with [size] colors 136 | and [c] defaults to [min 0.88 (1.0 - 0.06 *. (11 - ((n / 2) + 1)))]. *) 137 | 138 | (** {1:cyclic Cyclic} *) 139 | 140 | val cyclic_sinebow : ?a:float -> unit -> continuous 141 | (** [cylic_sinebow ()] is the sinebow cyclical scheme by 142 | {{:https://krazydad.com/tutorials/makecolors.php}Jim Bumgardner} 143 | and {{:http://basecase.org/env/on-rainbows}Charlie Loyd}. *) 144 | 145 | (** {1:qualitative Qualitative} 146 | 147 | Qualitative schemes are for nominal or categorical data. *) 148 | 149 | type qualitative = 150 | [ `Brewer_accent_8 | `Brewer_dark2_8 | `Brewer_paired_12 | `Brewer_pastel1_9 151 | | `Brewer_pastel2_8 | `Brewer_set1_9 | `Brewer_set2_8 | `Brewer_set3_12 152 | | `Tableau_10 | `Wijffelaars_17 ] 153 | (** The type for qualitative schemes. The 154 | suffix indicates the number of colors in the scheme. 155 | {ul 156 | {- The [`Brewer_*] schemes are 157 | {{:http://colorbrewer2.org/}colorbrewer} schemes by Cynthia Brewer.} 158 | {- The [`Tableau_10] scheme is by 159 | {{:https://research.tableau.com/user/maureen-stone}Maureen Stone}.} 160 | {- The [`Wijffelaars_17] scheme is by 161 | {{:https://research.tue.nl/en/studentTheses/synthesis-of-color-palettes} 162 | M. Wijffelaars}.}} *) 163 | 164 | val qualitative_size : qualitative -> int 165 | (** [qualitative_size q] is the number of colors in [q]. *) 166 | 167 | val qualitative : ?a:float -> qualitative -> unit -> discrete 168 | (** [qualitative q] is the qualitative scheme [q] with [qualitative_size q] 169 | colors and alpha component [a] (defaults to [1.]). *) 170 | 171 | val qualitative_wijffelaars : 172 | ?a:float -> ?eps:float -> ?r:float -> ?s:float -> ?b:float -> 173 | ?c:float -> size:int -> unit -> discrete 174 | (** [qualitative_wijffelaars ~a ~eps ~r ~s ~b ~c ~size ()] is a qualitative 175 | scheme with [size] colors. The parameters are: 176 | {ul 177 | {- [eps] in \[[0;1]\] is the hue shift, defines where the range of hues 178 | begin, defaults to [0] (yellow).} 179 | {- [r] in \[[0;1]\] is the used hue range proportion, defaults to [1].} 180 | {- [s] in \[[0;1]\] is saturation, the overall colorfullness, 181 | defaults to [0.5].} 182 | {- [b] in \[[0;1]\] is brightness, the overall lightness, defaults to 183 | [1].} 184 | {- [c] in \[[0;1]\] is contrast, the lightness difference 185 | between the darkest and the ligthest colors of the scheme, 186 | defaults to [0.5].} 187 | {- [a] is the alpha component, defaults to [1.].}} 188 | 189 | This implements the qualitative schemes described by 190 | {{:https://research.tue.nl/en/studentTheses/synthesis-of-color-palettes} 191 | M. Wijffelaars}. *) 192 | -------------------------------------------------------------------------------- /src/kit/gg__field2.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2023 The gg programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | open Gg 7 | 8 | let invalid_argf fmt = Printf.ksprintf invalid_arg fmt 9 | 10 | type 'a t = { dom : Box2.t; iw : int; ih : int; values : 'a array; } 11 | let make ~dom ~iw ~ih values = 12 | if iw * ih = Array.length values then { dom; iw; ih; values } else 13 | invalid_argf "grid size mimatch %d × %d <> %d" iw ih (Array.length values) 14 | 15 | let _of_fun ~dom f ~iw ~ih = 16 | let w = Box2.w dom and h = Box2.h dom in 17 | let ox = Box2.minx dom and oy = Box2.maxy dom in 18 | let xmax = float (iw - 1) and ymax = float (ih - 1) in 19 | let init k = 20 | let nx = (float (k mod iw)) /. xmax in 21 | let ny = (float (k / iw)) /. ymax in 22 | let x = ox +. w *. nx in 23 | let y = oy -. h *. ny in 24 | f (P2.v x y) 25 | in 26 | { iw; ih; dom; values = Array.init (iw * ih) init } 27 | 28 | let of_fun ~dom f ~dpu = 29 | let isize = V2.(dpu * Box2.size dom) in 30 | let iw = Float.to_int @@ Float.ceil (Size2.w isize) in 31 | let ih = Float.to_int @@ Float.ceil (Size2.h isize) in 32 | _of_fun ~dom f ~iw ~ih 33 | 34 | let of_fun' ?iw ?ih ~dom f = 35 | let ih_of_iw iw ~aspect = Float.to_int (Float.ceil (float iw) /. aspect) in 36 | let iw_of_ih ih ~aspect = Float.to_int (Float.ceil (float ih) *. aspect) in 37 | let iw, ih = match iw, ih with 38 | | Some iw, Some ih -> iw, ih 39 | | Some iw, None -> iw, ih_of_iw iw ~aspect:(Box2.aspect dom) 40 | | None, Some ih -> iw_of_ih ih ~aspect:(Box2.aspect dom), ih 41 | | None, None -> 42 | let aspect = Box2.aspect dom and s = 10_000 in 43 | if aspect < 1. then iw_of_ih s ~aspect, s else s, ih_of_iw s ~aspect 44 | in 45 | _of_fun ~dom f ~iw ~ih 46 | 47 | let values field = field.values 48 | let iw field = field.iw 49 | let ih field = field.ih 50 | let isize field = Size2.v (float field.iw) (float field.ih) 51 | let[@inline] valuei field ~xi ~yi = field.values.(field.iw * yi + xi) 52 | let dom field = field.dom 53 | let dpu field = 54 | let hdpu = (float (iw field)) /. Box2.w field.dom in 55 | let vdpu = (float (ih field)) /. Box2.h field.dom in 56 | Size2.v hdpu vdpu 57 | 58 | let map f field = { field with values = Array.map f field.values } 59 | let mapi f field = 60 | let fk field k v = 61 | let xi = k mod field.iw in 62 | let yi = k / field.iw in 63 | f ~xi ~yi v 64 | in 65 | { field with values = Array.mapi (fk field) field.values } 66 | 67 | let mapd f field = 68 | let xmax = float (field.iw - 1) and ymax = float (field.ih - 1) in 69 | let dox = Box2.minx field.dom and doy = Box2.maxy field.dom in 70 | let dw = Box2.w field.dom and dh = Box2.h field.dom in 71 | let fk field k v = 72 | let nx = (float (k mod field.iw)) /. xmax in 73 | let ny = (float (k / field.iw)) /. ymax in 74 | let x = dox +. dw *. nx in 75 | let y = doy -. dh *. ny in 76 | f (P2.v x y) v 77 | in 78 | { field with values = Array.mapi (fk field) field.values } 79 | 80 | let map_values f field = 81 | let values = f field.values in 82 | let vlen = Array.length values and flen = Array.length field.values in 83 | if vlen = flen then { field with values} else 84 | invalid_argf "result array length mimatch %d <> %d" vlen flen 85 | 86 | (* Isolines *) 87 | 88 | let iso_pos ~smooth ~w ~iso z0 z1 = 89 | (* finds the iso position in the [0;w] interval. *) 90 | if not smooth then w *. 0.5 else 91 | let dz = z1 -. z0 in 92 | if not (Float.is_finite dz) then w *. 0.5 else w *. ((iso -. z0) /. dz) 93 | 94 | type contour = 95 | { mutable first : P2.t list; (* head is first point of the polyline *) 96 | mutable last : P2.t list; (* head is last point of the polyline. *) 97 | mutable first_slot : int; (* slot where first lies (or -1) *) 98 | mutable last_slot : int; (* slot where last lies (or -1) *) } 99 | 100 | let no_slot = -1 101 | let no_contour = 102 | { first = []; last = []; first_slot = no_slot; last_slot = no_slot } 103 | 104 | let new_contour first last ~first_slot ~last_slot = 105 | { first = [first]; last = [last]; first_slot; last_slot } 106 | 107 | let close_contour c = List.rev_append c.last c.first 108 | 109 | let same_contour c0 c1 = c0 == c1 110 | let add_first c p ~slot = c.first <- p :: c.first; c.first_slot <- slot 111 | let add_last c p ~slot = c.last <- p :: c.last; c.last_slot <- slot 112 | let append slots c ~before = 113 | before.first <- List.rev_append c.last before.first; 114 | before.first <- List.rev_append (List.rev c.first) before.first; 115 | before.first_slot <- c.first_slot; 116 | slots.(c.first_slot) <- before 117 | 118 | (* For enumerating the cases we build the case number by starting 119 | from top left (z3, msb) to bottom left (z0, lsb) 120 | 121 | (xi,yi) z3 o---o z2 122 | | | 123 | z0 o---o z1 (xi+1,yi+1) 124 | 125 | We orient generated segments so that enclosed area >= iso is 126 | oriented ccw. The (xi,yi) coordinates are from the perspective of 127 | the array of samples not the field domain, top left z3 is (xi,yi). 128 | 129 | For the cases see https://en.wikipedia.org/wiki/Marching_squares\ 130 | #/media/File:Marching_squares_algorithm.svg 131 | 132 | - At the boundaries we assume everything neg_infinity, i.e. 133 | below the iso level. This makes the isolines closed. 134 | - Since we go from left to right and top to bottom this means that 135 | when we hit a left point we already saw it as a right point. And 136 | when we hit a top point we already saw it as a bottom point. 137 | - For stitching contours we keep a [slots] buffer that remembers the 138 | open contours from the previous line that we could stitch to 139 | on top of our cell. We also remember in [contour_prev] a possible 140 | contour we could stitch from the previous cell on the left. 141 | - Contours are deques so that we can add more at the end or at the 142 | beginning. We also remember in contours in which slots its current 143 | endpoints are (if any) as the slot may need updating when we append 144 | contours. *) 145 | 146 | let isoline ?(smooth = true) f iso = 147 | let vs = f.values and ih = f.ih and iw = f.iw and acc = ref [] in 148 | let slots = Array.make (iw + 1) no_contour in 149 | let contour_prev = ref no_contour in 150 | let xmin = Box2.minx f.dom and ymax = Box2.maxy f.dom in 151 | let dx = Box2.w f.dom /. (float iw -. 1.) in 152 | let dy = Box2.h f.dom /. (float ih -. 1.) in 153 | for yi = -1 to ih - 1 do 154 | let y = ymax -. float yi *. dy and yn = yi + 1 in 155 | let ri = yi * iw and rn = yn * iw in 156 | contour_prev := no_contour; 157 | for xi = -1 to iw - 1 do 158 | let x = xmin +. float xi *. dx and xn = xi + 1 in 159 | let z3 = if yi < 0 || xi < 0 then neg_infinity else vs.(ri + xi) in 160 | let z2 = if yi < 0 || xn = iw then neg_infinity else vs.(ri + xn) in 161 | let z1 = if yn = ih || xn = iw then neg_infinity else vs.(rn + xn) in 162 | let z0 = if yn = ih || xi < 0 then neg_infinity else vs.(rn + xi) in 163 | let case = 164 | ((if z3 >= iso then 1 else 0) lsl 3) lor 165 | ((if z2 >= iso then 1 else 0) lsl 2) lor 166 | ((if z1 >= iso then 1 else 0) lsl 1) lor 167 | ((if z0 >= iso then 1 else 0)) 168 | in 169 | let above = xi + 1 (* We have one slot for -1 *) in 170 | (* N.B. the [r] and [b] values are always the same and copy-pasted. *) 171 | match case with 172 | | 0 -> () 173 | | 1 -> 174 | let b = P2.v (x +. iso_pos ~smooth ~w:dx ~iso z0 z1) (y -. dy) in 175 | let c = !contour_prev in 176 | add_first ~slot:above c b; 177 | contour_prev := no_contour; slots.(above) <- c; 178 | | 2 -> 179 | let r = P2.v (x +. dx) (y -. iso_pos ~smooth ~w:dy ~iso z2 z1) in 180 | let b = P2.v (x +. iso_pos ~smooth ~w:dx ~iso z0 z1) (y -. dy) in 181 | let c = new_contour r b ~first_slot:no_slot ~last_slot:above in 182 | contour_prev := c; slots.(above) <- c; 183 | | 3 -> 184 | let r = P2.v (x +. dx) (y -. iso_pos ~smooth ~w:dy ~iso z2 z1) in 185 | add_first !contour_prev r ~slot:no_slot; 186 | | 4 -> 187 | let r = P2.v (x +. dx) (y -. iso_pos ~smooth ~w:dy ~iso z2 z1) in 188 | let c = slots.(above) in 189 | add_last c r ~slot:no_slot; 190 | contour_prev := c; slots.(above) <- no_contour; 191 | | 5 -> 192 | (if same_contour !contour_prev slots.(above) 193 | then (acc := (close_contour !contour_prev) :: !acc) 194 | else (append slots slots.(above) ~before:!contour_prev)); 195 | let r = P2.v (x +. dx) (y -. iso_pos ~smooth ~w:dy ~iso z2 z1) in 196 | let b = P2.v (x +. iso_pos ~w:dx ~smooth ~iso z0 z1) (y -. dy) in 197 | let c = new_contour b r ~first_slot:above ~last_slot:no_slot in 198 | contour_prev := c; slots.(above) <- c; 199 | | 6 -> 200 | let b = P2.v (x +. iso_pos ~smooth ~w:dx ~iso z0 z1) (y -. dy) in 201 | add_last slots.(above) b ~slot:above 202 | | 7 -> 203 | (if same_contour !contour_prev slots.(above) 204 | then (acc := (close_contour !contour_prev) :: !acc) 205 | else (append slots slots.(above) ~before:!contour_prev)); 206 | contour_prev := no_contour; slots.(above) <- no_contour; 207 | | 8 -> 208 | (if same_contour !contour_prev slots.(above) 209 | then (acc := (close_contour !contour_prev) :: !acc) 210 | else (append slots !contour_prev ~before:slots.(above))); 211 | contour_prev := no_contour; slots.(above) <- no_contour; 212 | | 9 -> 213 | let b = P2.v (x +. iso_pos ~smooth ~w:dx ~iso z0 z1) (y -. dy) in 214 | add_first slots.(above) b ~slot:above; 215 | | 10 -> 216 | let r = P2.v (x +. dx) (y -. iso_pos ~smooth ~w:dy ~iso z2 z1) in 217 | let b = P2.v (x +. iso_pos ~smooth ~w:dx ~iso z0 z1) (y -. dy) in 218 | let c = !contour_prev in 219 | add_last c b ~slot:above; 220 | add_first slots.(above) r ~slot:no_slot; 221 | contour_prev := slots.(above); slots.(above) <- c 222 | | 11 -> 223 | let r = P2.v (x +. dx) (y -. iso_pos ~smooth ~w:dy ~iso z2 z1) in 224 | add_first slots.(above) r ~slot:no_slot; 225 | contour_prev := slots.(above); slots.(above) <- no_contour; 226 | | 12 -> 227 | let r = P2.v (x +. dx) (y -. iso_pos ~smooth ~w:dy ~iso z2 z1) in 228 | add_last !contour_prev r ~slot:no_slot; 229 | | 13 -> 230 | let r = P2.v (x +. dx) (y -. iso_pos ~smooth ~w:dy ~iso z2 z1) in 231 | let b = P2.v (x +. iso_pos ~smooth ~w:dx ~iso z0 z1) (y -. dy) in 232 | let c = new_contour b r ~first_slot:above ~last_slot:no_slot in 233 | contour_prev := c; slots.(above) <- c; 234 | | 14 -> 235 | let b = P2.v (x +. iso_pos ~smooth ~w:dx ~iso z0 z1) (y -. dy) in 236 | let c = !contour_prev in 237 | add_last c b ~slot:above; 238 | contour_prev := no_contour; slots.(above) <- c; 239 | | 15 -> () 240 | | _ -> assert false 241 | done; 242 | done; 243 | (* The rev dance is still needed for js_of_ocaml *) 244 | Gg__pgon2.of_rings (List.rev_map Gg__ring2.of_pts !acc) 245 | 246 | type bigbytes = 247 | (int, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t 248 | 249 | let to_rgba ?(srgb = true) field ~color ~iw ~ih (img : bigbytes) = 250 | let open Bigarray in 251 | let vs = field.values and fw = field.iw and fh = field.ih in 252 | if fw = iw && fh = ih then begin 253 | (* No scaling, can shave a few ms *) 254 | for i = 0 to Array.length vs - 1 do 255 | let color = color vs.(i) in 256 | let c = if srgb then Color.to_srgb color else color in 257 | let p = i * 4 in 258 | Array1.set img (p ) (truncate (255. *. (Color.r c) +. 0.5)); 259 | Array1.set img (p+1) (truncate (255. *. (Color.g c) +. 0.5)); 260 | Array1.set img (p+2) (truncate (255. *. (Color.b c) +. 0.5)); 261 | Array1.set img (p+3) (truncate (255. *. (Color.a c) +. 0.5)); 262 | done 263 | end else 264 | let xr = float (fw - 1) /. float (iw - 1) in 265 | let yr = float (fh - 1) /. float (ih - 1) in 266 | for yi = 0 to ih - 1 do 267 | let row = 4 * yi * iw in 268 | let fy = Float.to_int (Float.round (float yi) *. yr) in 269 | for xi = 0 to iw - 1 do 270 | let fx = Float.to_int (Float.round (float xi) *. xr) in 271 | let v = vs.(fy * fw + fx) in 272 | let c = color v in 273 | let c = if srgb then Color.to_srgb c else c in 274 | let p = row + 4 * xi in 275 | Array1.set img (p ) (truncate (255. *. (Color.r c) +. 0.5)); 276 | Array1.set img (p+1) (truncate (255. *. (Color.g c) +. 0.5)); 277 | Array1.set img (p+2) (truncate (255. *. (Color.b c) +. 0.5)); 278 | Array1.set img (p+3) (truncate (255. *. (Color.a c) +. 0.5)); 279 | done 280 | done 281 | -------------------------------------------------------------------------------- /src/kit/gg__field2.mli: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2023 The gg programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | [@@@alert unstable 7 | "This interface may change in incompatible ways in the future."] 8 | 9 | (** Rectangular, finite, discrete 2D fields and isolines. 10 | 11 | A {e field} assigns values to each point of a domain. A {e domain} 12 | is a finite rectangular region of 2D space represented by a 13 | {!Gg.box2} value. 14 | 15 | The map of values is represented by a discrete, possibly 16 | non-uniform grid of values stored in a linear array. The first 17 | value in the array corresponds to the top-left point of the domain 18 | and the last value to the bottom-right point. This follows the 19 | usual convention for raster images (is it a good idea though ? 20 | {!Gg.Raster} did not). *) 21 | 22 | open Gg 23 | 24 | (** {1:fields Fields} *) 25 | 26 | type 'a t 27 | (** The type for fields with values of type ['a] *) 28 | 29 | val make : dom:Box2.t -> iw:int -> ih:int -> 'a array -> 'a t 30 | (** [make ~dom ~iw ~ih vs] is a field on domain [dom] represented 31 | by the grid [iw] × [ih] of values [vs]. Raises [Invalid_argument] if 32 | the size of [vs] is not [iw * ih]. *) 33 | 34 | val of_fun : dom:Box2.t -> (p2 -> 'a) -> dpu:float -> 'a t 35 | (** [of_fun ~dom f ~dpu] samples function [f] on the domain [dom] 36 | at [dpu] values per unit (“dots per unit”) in each direction. *) 37 | 38 | val of_fun' : ?iw:int -> ?ih:int -> dom:Box2.t -> (p2 -> 'a) -> 'a t 39 | (** [of_fun ?iw ?ih ~dom f] samples function [f] on the domain [dom] 40 | according to the grid defined by [iw] x [ih]. If a grid parameter 41 | is missing it is derived from the other for to provide a uniform 42 | grid on [dom]. If none is provided a uniform grid is generated 43 | with 1000 samples along the largest dimension; you get between 44 | 1000 and 1'000'000 samples depending on your aspect ratio. *) 45 | 46 | (** {1:props Properties} *) 47 | 48 | val values : 'a t -> 'a array 49 | (** [values field] are the values of [field]. *) 50 | 51 | (** {2:grid_space Grid space} *) 52 | 53 | val iw : 'a t -> int 54 | (** [iw field] is the width of the grid of [field]. *) 55 | 56 | val ih : 'a t -> int 57 | (** [ih field] is the height of the grid of [field]. *) 58 | 59 | val isize : 'a t -> Size2.t 60 | (** [isize field] is {!iw} and {!ih} as a size. *) 61 | 62 | val valuei : 'a t -> xi:int -> yi:int -> 'a 63 | (** [valuei field ~xi ~yi] is [(values field).((iw field) * yi + 64 | xi)]. The point [(0,0)] corresponds to top left corner of [dom 65 | field], and the point [(w-1,h-1)] to the bottom right one. *) 66 | 67 | (** {2:dom_space Domain space} *) 68 | 69 | val dom : 'a t -> Box2.t 70 | (** [dom field] is the 2D rectangular domain covered by [field]. *) 71 | 72 | val dpu : 'a t -> Size2.t 73 | (** [dpu field] is the horizontal and vertical resolution of [field] 74 | in values (dots) per unit of domain space. *) 75 | 76 | (** {1:transforming Transforming} *) 77 | 78 | val map : ('a -> 'b) -> 'a t -> 'b t 79 | (** [map f field] maps the values of [field] with [f]. *) 80 | 81 | val mapi : (xi:int -> yi:int -> 'a -> 'b) -> 'a t -> 'b t 82 | (** [mapi] is like {!map} but gives the grid coordinates to the 83 | mapping function. *) 84 | 85 | val mapd : (P2.t -> 'a -> 'b) -> 'a t -> 'b t 86 | (** [mapd] is like {!map} but gives the domain coordinates to 87 | the mapping function. *) 88 | 89 | val map_values : ('a array -> 'b array) -> 'a t -> 'b t 90 | (** [map_values f field] maps the values of [field] with [f]. 91 | Raises [Invalid_argument] if the resulting array size differs. *) 92 | 93 | (** {1:isolines Isolines} *) 94 | 95 | val isoline : ?smooth:bool -> float t -> float -> Gg__pgon2.t 96 | (** [isoline f iso] is a polygon bounding the areas of [f] where 97 | the value of [f] is [>= iso]. The rings of the polygon have 98 | correct winding order. Values outside the field [f] are assumed 99 | to be [neg_infinity] (< [iso]); this ensures that all polygons 100 | have a finite surface in {!dom}. 101 | 102 | The {{:https://en.wikipedia.org/wiki/Contour_line}isoline} is 103 | computed with the 104 | {{:https://en.wikipedia.org/wiki/Marching_squares} marching 105 | squares algorithm}. If [smooth] is [true] linear interpolation is 106 | used to find out the iso value on square boundaries, otherwise the 107 | iso value is assumed to be in the middle. 108 | 109 | {b Note.} We could generalize that, we'd need a comparator and 110 | an interpolator. *) 111 | 112 | (** {1:as_image As images} *) 113 | 114 | type bigbytes = 115 | (int, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t 116 | (** The type for bigbytes. *) 117 | 118 | val to_rgba : 119 | ?srgb:bool -> 'a t -> color:('a -> Color.t) -> iw:int -> ih:int -> 120 | bigbytes -> unit 121 | (** [to_rgba f color ~iw ~ih img] renders the field to [img] assumed 122 | to pixel data of size [iw] × [ih] with pixels in RGBA order and first 123 | index of [img] pointing on the top left pixel. If 124 | [srgb] is true colors are written in [sRGB] space otherwise the 125 | raw linear color is written. 126 | 127 | {b Note.} {{:https://en.wikipedia.org/wiki/Nearest-neighbor_interpolation} 128 | Nearest neighbor interpolation} is used to map the pixels. *) 129 | -------------------------------------------------------------------------------- /src/kit/gg__pgon2.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2022 The gg programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | open Gg 7 | 8 | (* Resizable array. *) 9 | 10 | module Rarray = struct 11 | type 'a t = 12 | { nil : 'a; 13 | mutable els : 'a array; 14 | mutable max : int; (* index of last element of [els]. *) } 15 | 16 | let make nil ~size = { nil; els = Array.make size nil; max = -1 } 17 | let grow a = 18 | let len = a.max + 1 in 19 | let els' = Array.make (2 * len) a.nil in 20 | Array.blit a.els 0 els' 0 len; a.els <- els' 21 | 22 | let length a = a.max + 1 23 | let add_last a v = 24 | let max = a.max + 1 in 25 | if max = Array.length a.els then grow a; 26 | a.max <- max; a.els.(max) <- v 27 | end 28 | 29 | (* Heap priority queue. Classical imperative implementation. Note that given 30 | the one shot use in this module we don't bother with shrinking. *) 31 | 32 | module type HEAPABLE = sig type t val compare : t -> t -> int val nil : t end 33 | module Heap (El : HEAPABLE) = struct 34 | let[@inline] heap_compare h i i' = El.compare h.(i) h.(i') 35 | let[@inline] heap_swap h i i' = let v = h.(i) in h.(i) <- h.(i'); h.(i') <- v 36 | let rec heap_up h i = 37 | if i = 0 then () else 38 | let p = (i - 1) / 2 in (* parent index. *) 39 | if heap_compare h i p < 0 then (heap_swap h i p; heap_up h p) 40 | 41 | let rec heap_down h max i = 42 | let start = 2 * i in 43 | let l = start + 1 in (* left child index. *) 44 | let r = start + 2 in (* right child index. *) 45 | if l > max then () (* no child, stop *) else (* find smallest child k. *) 46 | let k = if r > max then l else (if heap_compare h l r < 0 then l else r) in 47 | if heap_compare h i k > 0 then (heap_swap h i k; heap_down h max k) 48 | 49 | type t = El.t Rarray.t (* array of elements with the heap invariant *) 50 | 51 | let make ~size = Rarray.make El.nil ~size 52 | let peek (h : t) = if h.max < 0 then None else Some (h.els.(0)) 53 | let take (h : t) = 54 | if h.max < 0 then None else 55 | let v = Some h.els.(0) in 56 | let last = h.els.(h.max) in 57 | h.els.(h.max) <- El.nil; h.max <- h.max - 1; h.els.(0) <- last; 58 | heap_down h.els h.max 0; 59 | v 60 | 61 | let add (h : t) e = 62 | let max = h.max + 1 in 63 | if max = Array.length h.els then Rarray.grow h; 64 | h.max <- max; h.els.(h.max) <- e; 65 | heap_up h.els h.max 66 | end 67 | 68 | (* Polygons *) 69 | 70 | let min_max_coords rs = (* assert (cs <> []) *) 71 | let rec contour_loop cs xmin ymin xmax ymax = function 72 | | [] -> (loop[@tailcall]) xmin ymin xmax ymax cs 73 | | p :: ps -> 74 | let px = V2.x p and py = V2.y p in 75 | let xmin = Float.min xmin px and ymin = Float.min ymin py in 76 | let xmax = Float.max xmax px and ymax = Float.max ymax py in 77 | (contour_loop[@tailcall]) cs xmin ymin xmax ymax ps 78 | and loop xmin ymin xmax ymax = function 79 | | [] -> (P2.v xmin ymin), (P2.v xmax ymax) 80 | | r :: rs -> 81 | (contour_loop[@tailcall]) rs xmin ymin xmax ymax (Gg__ring2.pts r) 82 | in 83 | let fmax = Float.max_float and fmin = ~-. Float.max_float in 84 | loop fmax fmax fmin fmin rs 85 | 86 | let min_max_nil = P2.o, P2.o 87 | 88 | type t = 89 | { rings : Gg__ring2.t list; 90 | (* Note. We do not store this as a Box2.t value because we need a 91 | precise Box2.maxx for the boolean operation optimizations 92 | cases. If we get an under approximation because of the minx 93 | +. (maxx - minx) computation the algo returns bogus results 94 | (some events that need to be in the list resulting from the 95 | sweep may not be in). 96 | 97 | We use a mutable field instead of a lazy value. In `js_of_ocaml` that 98 | allows us pass polygons through the structured clone algorithm. *) 99 | mutable min_max : (P2.t * P2.t) option } 100 | 101 | let empty = { rings = []; min_max = None } 102 | let of_rings rings = 103 | let rings = List.filter (fun r -> not (Gg__ring2.is_empty r)) rings in 104 | if rings = [] then empty else { rings; min_max = None } 105 | 106 | (* Predicates *) 107 | 108 | let is_empty p = p.rings = [] 109 | 110 | (* Properties *) 111 | 112 | let rings p = p.rings 113 | 114 | let min_max p = match p.min_max with 115 | | Some min_max -> min_max 116 | | None -> 117 | let min_max = min_max_coords p.rings in 118 | p.min_max <- Some min_max; min_max 119 | 120 | let box p = 121 | if is_empty p then Box2.empty else 122 | let min, max = min_max p in 123 | Box2.of_pts min max 124 | 125 | (* Traversals *) 126 | 127 | let fold_rings f p acc = List.fold_left (Fun.flip f) acc p.rings 128 | 129 | (* Boolean operations. 130 | 131 | The algorithm here is based on: 132 | 133 | A new algorithm for computing Boolean operation on polygons. 134 | Francisco Martínez et al. https://doi.org/10.1016/j.cageo.2008.08.009 135 | 136 | A simple algorithm for Boolean operations on polygons. 137 | Francisco Martínez et al. https://doi.org/10.1016/j.advengsoft.2013.04.004 138 | 139 | The second paper improves the first one and is the one we implement. Both 140 | papers are useful to understand what is going on. This implementation is 141 | drawn from the public domain reference C++ implementation found at 142 | https://www4.ujaen.es/~fmartin/bool_op.html. However note that the version 143 | found there as of 2022 is not bug free. *) 144 | 145 | type bool_op = Union | Diff | Inter | Xor 146 | type polygon = Subject | Clipping (* left or right argument of the bool ops *) 147 | type overlap = (* For overlap information see §7.2 of the first paper. *) 148 | | No | Not_contributing | Same_inout | Different_inout 149 | 150 | (* Sweep line events. Sweep events occur at the endpoints of polygon 151 | segments and their intersections. *) 152 | 153 | module Event = struct 154 | type t = 155 | { polygon : polygon; (* polygon to which the segment belongs *) 156 | pt : P2.t; (* endpoint of the segment. *) 157 | mutable other : t; (* event for the other endpoint of the segment *) 158 | mutable is_left : bool; (* [pt] is the left endpoint of the segment. *) 159 | (* Information set during the sweep see §4 of the paper. *) 160 | mutable overlap : overlap; (* See §7.2 of the first paper. *) 161 | mutable inout : bool; (* [true] if a ray shot from below the polygon 162 | gets out [polygon]. *) 163 | mutable other_poly_inout : bool; (* same as [inout] but for the closet 164 | edge below of the other polygon. *) 165 | mutable in_result : bool; (* [true] if endpoint belongs to the result *) 166 | mutable below_in_result : t; (* points to the closest edge below also 167 | in the result. [nil] if none. *) 168 | mutable resort : bool; 169 | (* [true] if the event needs to be resorted when it gets out of the 170 | prioriy queue because [is_left] was mutated during division. a*) 171 | (* For connecting the results see §5 of the paper. *) 172 | mutable sort_index : int; 173 | mutable contour_id : int; 174 | mutable result_inout : bool; } 175 | 176 | let ppv2 = V2.pp_f (fun ppf v -> Format.fprintf ppf "%.17f" v) 177 | let pp_dump ppf e = 178 | Format.fprintf ppf "@[%d:%s:%b %a - %d %a@]" 179 | e.sort_index (if e.is_left then "L" else "R") 180 | e.in_result ppv2 e.pt e.other.sort_index ppv2 e.other.pt 181 | 182 | let rec nil = 183 | (* nil event for initializing data structures. Careful, compare with 184 | (==), (=) diverges :-) *) 185 | { polygon = Subject; pt = P2.o; other = nil; is_left = true; 186 | overlap = No; inout = false; other_poly_inout = false; 187 | in_result = false; below_in_result = nil; resort = false; sort_index = -1; 188 | contour_id = -1; result_inout = false; } 189 | 190 | let v ~polygon ~pt ~is_left = 191 | { polygon; pt; other = nil; is_left; overlap = No; inout = false; 192 | other_poly_inout = false; in_result = false; below_in_result = nil; 193 | resort = false; sort_index = -1; contour_id = -1; result_inout = false; } 194 | 195 | let is_seg_vertical e = Float.equal (P2.x e.pt) (P2.x e.other.pt) 196 | 197 | let p2_orient = P2.orient 198 | 199 | let is_seg_below ~seg:e ~pt = (* [true] if segment [e] is below [pt] *) 200 | if e.is_left 201 | then p2_orient e.pt e.other.pt pt > 0. 202 | else p2_orient e.other.pt e.pt pt > 0. 203 | 204 | let is_seg_above ~seg:e ~pt = not (is_seg_below ~seg:e ~pt) 205 | 206 | let segs_collinear e0 e1 = 207 | (* The reference implementation used the following which is not a 208 | robust collinearity test. We use the relative epsilon collinearity 209 | found in Gg.P2.seg_inter. It fixes some of our tests. *) 210 | (* P2.orient e0.pt e0.other.pt e1.pt = 0. && 211 | P2.orient e0.pt e0.other.pt e1.other.pt = 0. *) 212 | let eps2 = 1e-8 in 213 | let p0 = e0.pt and p1 = e0.other.pt in 214 | let q0 = e1.pt and q1 = e1.other.pt in 215 | let d0x = P2.x p1 -. P2.x p0 and d0y = P2.y p1 -. P2.y p0 in 216 | let d1x = P2.x q1 -. P2.x q0 and d1y = P2.y q1 -. P2.y q0 in 217 | let kross = (d0x *. d1y) -. (d0y *. d1x) in 218 | let sqr_kross = kross *. kross in 219 | let sqr_len0 = (d0x *. d0x) +. (d0y *. d0y) in 220 | let sqr_len1 = (d1x *. d1x) +. (d1y *. d1y) in 221 | if sqr_kross > eps2 *. sqr_len0 *. sqr_len1 then false else 222 | let ex = P2.x q0 -. P2.x p0 and ey = P2.y q0 -. P2.y p0 in 223 | let sqr_lene = (ex *. ex) +. (ey *. ey) in 224 | let kross = (ex *. d0y) -. (ey *. d0x) in 225 | let sqr_kross = kross *. kross in 226 | if sqr_kross > eps2 *. sqr_len0 *. sqr_lene then false else true 227 | 228 | (* Order for the priority queue. Orders first from left to right, then 229 | bottom to top, then right endpoints before left and other special cases. *) 230 | let compare e0 e1 = 231 | let c = Float.compare (P2.x e0.pt) (P2.x e1.pt) in 232 | if c <> 0 then c (* smallest x processed before *) else 233 | let c = Float.compare (P2.y e0.pt) (P2.y e1.pt) in 234 | if c <> 0 then c (* smallest y processed before *) else 235 | (* e0.pt and e1.pt coincide. *) 236 | let c = Bool.compare e0.is_left e1.is_left in 237 | if c <> 0 then c (* right endpoint processed before left *) else 238 | if segs_collinear e0 e1 then 239 | (* Not exactly sure whether this is useful, I think it does 240 | label clipping as non-contributing on overlaps but I don't think 241 | it matters. *) 242 | Stdlib.compare e0.polygon e1.polygon (* Subject before Clipping *) 243 | else 244 | if is_seg_above ~seg:e0 ~pt:e1.other.pt 245 | then 1 else -1 (* event of bottom seg before *) 246 | 247 | let in_result op e = match e.overlap with 248 | | No -> 249 | begin match op with 250 | | Inter -> not e.other_poly_inout 251 | | Union -> e.other_poly_inout 252 | | Diff -> 253 | (e.polygon = Subject && e.other_poly_inout) || 254 | (e.polygon = Clipping && not e.other_poly_inout) 255 | | Xor -> true 256 | end 257 | | Same_inout -> (match op with Inter | Union -> true | _ -> false) 258 | | Different_inout -> (match op with Diff -> true | _ -> false) 259 | | Not_contributing -> false 260 | 261 | (* These mutations do not affect the order in [q] or [s]. 262 | [below] is the event for the segment just below in the sweep line status. 263 | Mutating these fields has no effect on the comparison done by 264 | [Event.compare] and [Status.seg_compare]. *) 265 | let set_fields op e ~below = match below with 266 | | None -> 267 | e.inout <- false; 268 | e.other_poly_inout <- true; (* We are outside the other *) 269 | e.in_result <- in_result op e; 270 | | Some below -> 271 | let inout, other_poly_inout = match e.polygon = below.polygon with 272 | | true -> not below.inout, below.other_poly_inout 273 | | false -> 274 | not below.other_poly_inout (* that other is ours *), 275 | if is_seg_vertical below then not below.inout else below.inout 276 | in 277 | let below_in_result = 278 | match not below.in_result || is_seg_vertical below with 279 | | true -> below.below_in_result | false -> below 280 | in 281 | e.inout <- inout; 282 | e.other_poly_inout <- other_poly_inout; 283 | e.below_in_result <- below_in_result; 284 | e.in_result <- in_result op e 285 | 286 | let filter_and_sort evs = 287 | (* Results needs to be resorted because of overlaps. We may 288 | also have dupes in [evs] because of reprocesses. *) 289 | let module Eset = 290 | Set.Make (struct type nonrec t = t let compare = compare end) 291 | in 292 | let add_to_result acc e = 293 | if (e.is_left && e.in_result) || (not e.is_left && e.other.in_result) 294 | then Eset.add e acc else acc 295 | in 296 | let evs = List.fold_left add_to_result Eset.empty evs in 297 | let r = Array.make (Eset.cardinal evs) nil in 298 | let add e i = 299 | (* XXX the original algo swaps if r.(i).pos and r.(i).other.pos 300 | if not r.(i).is_left. It's unclear to me why this is done and 301 | therefore not done here. *) 302 | e.sort_index <- i; r.(i) <- e; i + 1 303 | in 304 | ignore (Eset.fold add evs 0); r 305 | end 306 | 307 | (* Sweep line status. 308 | 309 | This holds, via an ordered set of [is_left] Event.t values, all 310 | the segments that intersect the sweep line. The general idea is to orders 311 | the segments from bottom to top, but there are many special cases to 312 | treat. *) 313 | module Status = struct 314 | (* Order for the sweep line status. Orders the is_left events first from 315 | bottom to top and then other special cases. *) 316 | let seg_compare (e0 : Event.t) (e1 : Event.t) = 317 | assert (e0.is_left && e1.is_left); 318 | if e0 == e1 then 0 else 319 | if Event.segs_collinear e0 e1 then begin 320 | (* N.B. the ref impl. fails on these things *) 321 | let c = Event.compare e0 e1 in 322 | let ll, lr = if c < 0 then e0, e1 else e1, e0 in 323 | if V2.x ll.other.pt < V2.x lr.other.pt then 324 | (* lr prolonges ll, let the prolongation be above or below 325 | according to the segment's direction. *) 326 | let c' = Float.compare (V2.y ll.pt) (V2.y lr.pt) in 327 | if c' <> 0 then c' else (* Horizontal, use ref implem. *) 328 | let c' = Stdlib.compare e0.polygon e1.polygon in 329 | if c' <> 0 then c' else c 330 | else 331 | (* Like in the reference implem. *) 332 | let c' = Stdlib.compare e0.polygon e1.polygon in 333 | if c' <> 0 then c' else c 334 | end else 335 | if V2.equal e0.pt e1.pt (* When left coincide use right point to sort *) 336 | then (if Event.is_seg_below ~seg:e0 ~pt:e1.other.pt then -1 else 1) else 337 | if Float.equal (P2.x e0.pt) (P2.x e1.pt) 338 | then 339 | let c = Float.compare (P2.y e0.pt) (P2.y e1.pt) in 340 | if c <> 0 then c else Event.compare e0 e1 (* XXX *) 341 | else 342 | (* XXX no longer understand this. *) 343 | if Event.compare e0 e1 < 0 (* e0 before e1 in the queue ? *) 344 | then (if Event.is_seg_below ~seg:e0 ~pt:e1.pt then -1 else 1) 345 | else (if Event.is_seg_above ~seg:e1 ~pt:e0.pt then -1 else 1) 346 | 347 | include Set.Make (struct type t = Event.t let compare = seg_compare end) 348 | let assert' s = for_all (fun e -> e.is_left) s 349 | let above e = find_first_opt (fun e' -> seg_compare e' e > 0) 350 | let below e = find_last_opt (fun e' -> seg_compare e' e < 0) 351 | end 352 | 353 | module Equeue = struct 354 | include Heap (Event) 355 | 356 | let rec drain q = 357 | let rec loop q acc = match take q with 358 | | None -> List.rev acc | Some e -> loop q (e :: acc) 359 | in 360 | loop q [] 361 | 362 | let heap_take = take 363 | let rec take q = match heap_take q with 364 | | None -> None 365 | | Some e when e.Event.resort -> e.resort <- false; add q e; take q 366 | | _ as r -> r 367 | 368 | let add_segments q ~polygon p = 369 | let add_seg p0 p1 q = 370 | if V2.equal p0 p1 then (* skip degenerate segment *) q else 371 | let p0_is_left = V2.compare p0 p1 < 0 in 372 | let e0 = Event.v ~polygon ~pt:p0 ~is_left:p0_is_left in 373 | let e1 = Event.v ~polygon ~pt:p1 ~is_left:(not p0_is_left) in 374 | e0.Event.other <- e1; e1.Event.other <- e0; 375 | add q e0; add q e1; 376 | q 377 | in 378 | let add_contour c q = Gg__ring2.fold_segs add_seg c q in 379 | ignore (fold_rings add_contour p q) 380 | 381 | let make ~subject:p0 ~clipping:p1 = 382 | let q = make ~size:1024 in 383 | add_segments q ~polygon:Subject p0; add_segments q ~polygon:Clipping p1; q 384 | 385 | let divide_seg q e ~at:pt = (* segment e-e.other becomes e-r and l-e.other *) 386 | assert (e.Event.is_left); 387 | let el = e and er = e.Event.other in 388 | let r = Event.v ~polygon:e.Event.polygon ~pt ~is_left:false in 389 | let l = Event.v ~polygon:e.Event.polygon ~pt ~is_left:true in 390 | el.other <- r; r.other <- el; l.other <- er; er.other <- l; 391 | (* Fix processing order in case of roundings error. *) 392 | if not (Event.compare l l.other <= 0) 393 | (* [l.other] is still in the priority queue we ask to resort 394 | it when it pops out from the queue. *) 395 | then (l.is_left <- false; l.other.is_left <- true; l.other.resort <- true); 396 | let e_order_swap = 397 | if not (Event.compare r.other r <= 0) 398 | then (r.is_left <- true; (* e *) r.other.is_left <- false; true) 399 | else false 400 | in 401 | add q r; add q l; 402 | (* We return [l] to check for seg. sort changes *) 403 | l, e_order_swap 404 | 405 | let handle_intersection_pt s q ~below b0 b1 ~above a0 a1 ~pt:i = 406 | let eq_left = V2.equal b0 a0 and eq_right = V2.equal b1 a1 in 407 | if eq_left || eq_right then (* segs: > or <, nothing to do *) Ok s else 408 | (* A segment only gets divided if [i] is not one of its endpoints. *) 409 | let divide_below = not (V2.equal b0 i) && not (V2.equal b1 i) in 410 | let divide_above = not (V2.equal a0 i) && not (V2.equal a1 i) in 411 | (* If we mutate the events their sort can change. Remove them before. *) 412 | (* assert (Status.mem below s && Status.mem above s); *) 413 | let s = if divide_below then Status.remove below s else s in 414 | let s = if divide_above then Status.remove above s else s in 415 | let bl, below_order_swap = 416 | if divide_below then divide_seg q below ~at:i else Event.nil, false 417 | in 418 | let al, above_order_swap = 419 | if divide_above then divide_seg q above ~at:i else Event.nil, false 420 | in 421 | let s = 422 | if above_order_swap || 423 | (divide_below && not divide_above && Status.seg_compare bl above > 0) 424 | (* New segment [bl] is above [above], need to reprocess it. *) 425 | then (add q above; s) 426 | else (if divide_above then (* re-add *) Status.add above s else s) 427 | in 428 | let s = 429 | if below_order_swap || 430 | (divide_above && not divide_below && Status.seg_compare al below < 0) 431 | (* New segment [al] is below [below], need to reprocess it. *) 432 | then (add q below; s) 433 | else (if divide_below then (* re-add *) Status.add below s else s) 434 | in 435 | (* Note that if [divide_above] and [divide_below] are both true. [below] and 436 | [above] no longer exist as such. For the new segments, those that 437 | start with [a0] and [b0] should be sorted correctly relative to each 438 | other by the virtue of [below] and [above] being sorted. The other 439 | ones will be sorted in the future and their left points should be on the 440 | right of those segments starting in [a0] and [b0]. So nothing 441 | special has to be done. *) 442 | Ok s 443 | 444 | let update_inout op seg s = 445 | (* These mutations do not affect order in [q] or [s]. *) 446 | let below = Status.below seg s in 447 | Event.set_fields op seg ~below 448 | 449 | let update_overlap_fields ~keep ~drop = 450 | (* These mutations do not affect order in [q] or [s]. [keep] and [drop] 451 | are the same segment, we need only one in the result. *) 452 | drop.Event.overlap <- Not_contributing; 453 | keep.Event.overlap <- 454 | if keep.Event.inout = drop.Event.inout 455 | then Same_inout else Different_inout 456 | 457 | let handle_overlap op s q ~below ~above = 458 | (* Overlap needs to handle these five cases: 459 | *......* *....* *....* *..* *......* 460 | *------* *------* *------* *------* *------* 461 | 462 | XXX The update_inout is still a bit unclear. Also should we 463 | systematically resort the actual overlap. 464 | *) 465 | let eq_left = V2.equal below.Event.pt above.Event.pt in 466 | let eq_right = V2.equal below.Event.other.pt above.Event.other.pt in 467 | if eq_left && eq_right then begin (* full overlap *) 468 | update_overlap_fields ~keep:below ~drop:above; 469 | update_inout op below s; update_inout op above s; 470 | s 471 | end else if eq_left then begin (* longest seg needs to be cut *) 472 | let keep, to_cut = 473 | if Event.compare below.other above.other < 0 474 | then below, above else above, below 475 | in 476 | let s = Status.remove to_cut s (* will mutate *) in 477 | let _new_seg, swap = divide_seg q to_cut ~at:keep.other.pt in 478 | let s = Status.add (if swap then to_cut.other else to_cut) s in 479 | update_overlap_fields ~keep ~drop:to_cut; 480 | update_inout op below s; update_inout op above s; 481 | s 482 | end else if eq_right then begin (* longest seg needs to be cut *) 483 | let keep, to_cut = 484 | if Event.compare below above < 0 485 | then above, below else below, above 486 | in 487 | let s = Status.remove to_cut s (* will mutate *) in 488 | (* XXX new_seg will get into the queue not sure that's a good idea. *) 489 | let new_seg, swap = divide_seg q to_cut ~at:keep.pt in 490 | let s = Status.add (if swap then to_cut.other else to_cut) s in 491 | new_seg.inout <- to_cut.inout; (* XXX maybe divide_seg should do that. *) 492 | update_overlap_fields ~keep ~drop:new_seg; 493 | s 494 | end else begin 495 | (* either one segment contains the other or partial overlap *) 496 | let leftmost, left = 497 | if Event.compare below above < 0 498 | then below, above else above, below 499 | in 500 | let rightmost, right = 501 | if Event.compare below.other above.other > 0 502 | then below, above else above, below 503 | in 504 | if leftmost == rightmost then begin (* leftmost contains left *) 505 | let keep, to_cut_twice = left, leftmost in 506 | (* XXX new_segs will get into the queue not sure that's a good idea. *) 507 | let s = Status.remove to_cut_twice s (* will mutate *) in 508 | let new_seg, swap = divide_seg q to_cut_twice ~at:keep.pt in 509 | new_seg.inout <- to_cut_twice.inout; 510 | update_overlap_fields ~keep ~drop:new_seg; 511 | let _new_seg, _swap = divide_seg q new_seg ~at:keep.other.pt in 512 | let to_cut_twice = if swap then to_cut_twice.other else to_cut_twice in 513 | let s = Status.add to_cut_twice s in 514 | s 515 | end else begin 516 | let s = Status.remove leftmost s (* will mutate *) in 517 | let s = Status.remove left s (* will mutate *) in 518 | let leftmost_at = left.pt and left_at = leftmost.other.pt in 519 | let new_seg, lefmost_swap = divide_seg q leftmost ~at:leftmost_at in 520 | let _new_seg, left_swap = divide_seg q left ~at:left_at in 521 | new_seg.inout <- leftmost.inout; 522 | update_overlap_fields ~keep:left ~drop:new_seg; 523 | let leftmost = if lefmost_swap then leftmost.other else leftmost in 524 | let left = if left_swap then left.other else left in 525 | let s = Status.add leftmost s in 526 | let s = Status.add left s in 527 | s 528 | end 529 | end 530 | 531 | let handle_intersection op s q ~below ~above = 532 | assert (Status.mem below s && Status.mem above s); 533 | assert (below.Event.is_left && above.Event.is_left); 534 | let b0 = below.Event.pt and b1 = below.other.pt in 535 | let a0 = above.Event.pt and a1 = above.other.pt in 536 | let r = match P2.seg_inter ~p0:b0 ~p1:b1 ~q0:a0 ~q1:a1 () with 537 | | `None -> Ok s 538 | | `Pt pt -> handle_intersection_pt s q ~below b0 b1 ~above a0 a1 ~pt 539 | | `Seg (i0, i1) -> 540 | if below.Event.polygon = above.Event.polygon 541 | then Error s (* self-overlap not supported by the algo *) 542 | else Ok (handle_overlap op s q ~below ~above) 543 | in 544 | let s = match r with Ok s -> s | Error s -> s in 545 | assert (Status.assert' s); 546 | r 547 | end 548 | 549 | module Sweep = struct 550 | (* The sweep. Finds all the intersection and attributes segments to 551 | the result. *) 552 | 553 | let[@inline] left_pt err op q s e = 554 | let s = Status.add e s in 555 | let s = match Status.above e s with 556 | | None -> s 557 | | Some above -> 558 | Event.set_fields op e ~below:(Status.below e s); 559 | match Equeue.handle_intersection op s q ~below:e ~above with 560 | | Ok s -> s | Error s -> err := true; s 561 | in 562 | if not e.is_left (* order swap, will be reprocessed *) then s else 563 | let below = Status.below e s (* note that [s] may have changed here *) in 564 | Event.set_fields op e ~below; 565 | match below with 566 | | None -> s 567 | | Some b -> 568 | let s = match Equeue.handle_intersection op s q ~below:b ~above:e with 569 | | Ok s -> s | Error s -> err := true; s 570 | in 571 | if not e.is_left then s else 572 | ((* Removes a panic from the test suite, but this should be done 573 | in a principled way in handle_intersection since it adds another*) 574 | Event.set_fields op e ~below:(Status.below e s); s) 575 | 576 | let[@inline] right_pt err op q s e = 577 | let e = e.Event.other (* work on the left end which is the one in [s] *) in 578 | let below = Status.below e s and above = Status.above e s in 579 | let s = Status.remove e s in 580 | match below, above with 581 | | Some below, Some above -> 582 | begin match Equeue.handle_intersection op s q ~below ~above with 583 | | Ok s -> s | Error s -> err := true; s 584 | end 585 | | _ -> s 586 | 587 | let[@inline] maxx p = 588 | if is_empty p then -. min_float else P2.x (snd (min_max p)) 589 | 590 | let events op p0 p1 = 591 | let rec loop err op b0maxx minmaxx evs q s = match Equeue.take q with 592 | | None -> evs 593 | | Some e -> 594 | assert (e == e.other.other); 595 | (* assert (if e.is_left then not (Status.mem e s) else true); *) 596 | match op with 597 | (* Optimizations. See point 2. in §8 of the paper. Note, we 598 | need to make sure we have all the events in [evs] this means we 599 | need a precise minmaxx and b0max. Alternatively we could 600 | drain the queue in [evs]. *) 601 | | Inter when P2.x e.pt > minmaxx -> evs 602 | | Diff when P2.x e.pt > b0maxx -> evs 603 | | _ -> 604 | let evs = e :: evs in 605 | let s = match e.is_left with 606 | | true -> (left_pt[@inlined]) err op q s e 607 | | false -> (right_pt[@inlined]) err op q s e 608 | in 609 | (loop[@tailcal]) err op b0maxx minmaxx evs q s 610 | in 611 | let b0maxx = maxx p0 in 612 | let minmaxx = Float.min b0maxx (maxx p1) in 613 | let q = Equeue.make ~subject:p0 ~clipping:p1 in 614 | let errs = ref false in 615 | let evs = loop errs op b0maxx minmaxx [] q Status.empty in 616 | if !errs then Error evs else Ok evs 617 | 618 | let debug_stepper op p0 p1 = (* XXX mostly copies [events]. *) 619 | let b0maxx = maxx p0 in 620 | let minmaxx = Float.min b0maxx (maxx p1) in 621 | let q = Equeue.make ~subject:p0 ~clipping:p1 in 622 | let err = ref false in 623 | let s = ref Status.empty in 624 | let step () = match Equeue.take q with 625 | | None -> None 626 | | Some e -> 627 | match op with 628 | | Inter when P2.x e.pt > minmaxx -> None 629 | | Diff when P2.x e.pt > b0maxx -> None 630 | | _ -> 631 | let s' = if e.is_left then Status.add e !s else !s in 632 | let below = Status.below (if e.is_left then e else e.other) s' in 633 | let above = Status.above (if e.is_left then e else e.other) s' in 634 | s := (match e.is_left with 635 | | true -> (left_pt[@inlined]) err op q !s e 636 | | false -> (right_pt[@inlined]) err op q !s e); 637 | Some (below, e, above, Status.elements s') 638 | in 639 | step 640 | 641 | let debug_result ?(filtered = true) op p0 p1 = match events op p0 p1 with 642 | | Ok evs | Error evs -> 643 | if filtered then Array.to_list (Event.filter_and_sort evs) else evs 644 | end 645 | 646 | module Topology = struct 647 | (* Final part of the algorithm finds contours and their orientation 648 | in the soup of result segments. 649 | 650 | TODO for now we don't compute the holes direction but interpreting 651 | the result with the even-odd rule should yield correct results. *) 652 | 653 | type contour = 654 | { mutable depth : int; 655 | mutable holeof : int; 656 | mutable holes : int list; 657 | mutable is_external : bool; 658 | mutable contour : P2.t list; } 659 | 660 | let contour () = 661 | { depth = -1; holeof = -1; holes = []; is_external = true; contour = [] } 662 | 663 | let nil = contour () 664 | 665 | type t = contour Rarray.t 666 | let make ~size = Rarray.make nil ~size 667 | let get cid (cs : t) = assert (0 <= cid && cid <= cs.max); cs.els.(cid) 668 | let new' (cs : t) = 669 | let c = contour () in Rarray.add_last cs c; Rarray.length cs - 1, c 670 | 671 | let final_polygon (css : t) = 672 | let cs = ref [] and hs = ref [] in 673 | for i = css.max downto 0 do 674 | cs := css.els.(i).contour :: !cs; hs := css.els.(i).holes :: !hs 675 | done; 676 | of_rings (List.map Gg__ring2.of_pts !cs), !hs 677 | 678 | let assigned e = e.Event.contour_id <> -1 679 | 680 | let init_contour errs cs start = 681 | let contour_id, c as r = new' cs in 682 | let below = start.Event.below_in_result in 683 | if below == Event.nil then r else 684 | if not (assigned below) 685 | then (errs := !errs ^ Format.asprintf "UNASSIGNED BELOW!@."; r) else 686 | let belowc = get below.contour_id cs in 687 | if below.result_inout then 688 | (belowc.holes <- contour_id :: belowc.holes; 689 | c.holeof <- below.contour_id; 690 | c.depth <- belowc.depth + 1; 691 | c.is_external <- false; 692 | r) 693 | else 694 | if not belowc.is_external then 695 | (let parent = get belowc.holeof cs in 696 | parent.holes <- contour_id :: parent.holes; 697 | c.holeof <- belowc.holeof; 698 | c.depth <- belowc.depth; 699 | c.is_external <- false; 700 | r) 701 | else r 702 | 703 | let find_kont errs ~panic r (start : Event.t) = 704 | let rec find_down r i = 705 | (* N.B. theoretically this should always find a non-assigned event 706 | with point [start.pt]. But it's a bit unclear what happens with 707 | our non-failing behaviour on overlapping self-edges. So if we 708 | hit the bottom we simply return [panic] which stops the contour 709 | walk process (see value given at calling point). *) 710 | if i < 0 711 | then (errs := 712 | !errs ^ (Format.asprintf "PANIC! %d %a@." 713 | start.Event.sort_index Event.ppv2 start.Event.pt); 714 | panic) else 715 | if assigned r.(i) then find_down r (i - 1) else r.(i) 716 | in 717 | let rec find_up r max i start = 718 | if i <= max && V2.equal r.(i).Event.pt start.Event.pt 719 | then (if assigned r.(i) then find_up r max (i + 1) start else r.(i)) 720 | else find_down r (start.Event.sort_index - 1) 721 | in 722 | find_up r (Array.length r - 1) (start.sort_index + 1) start 723 | 724 | let next_contour errs cs evs start = 725 | let rec loop errs evs cid c (start : Event.t) (e : Event.t) = 726 | e.contour_id <- cid; e.other.contour_id <- cid; 727 | c.contour <- e.pt :: c.contour; 728 | match V2.equal start.pt e.other.pt with 729 | | true -> if c.depth mod 2 = 1 then c.contour <- List.rev c.contour 730 | | false -> 731 | let another_other = find_kont errs ~panic:start.other evs e.other in 732 | loop errs evs cid c start another_other 733 | in 734 | let cid, c = init_contour errs cs start in 735 | loop errs evs cid c start start 736 | 737 | let find evs = 738 | let errs = ref "" in 739 | let rec loop errs r max i cs = 740 | if i > max then cs else 741 | if assigned r.(i) then loop errs r max (i + 1) cs else 742 | (next_contour errs cs r r.(i); loop errs r max (i + 1) cs) 743 | in 744 | let css = loop errs evs (Array.length evs - 1) 0 (make ~size:256) in 745 | let r = final_polygon css in 746 | if !errs = "" then Ok r else Error (r, !errs) 747 | end 748 | 749 | let bool_op_empty_cases op p0 p1 = 750 | if not (is_empty p0) && not (is_empty p1) then None else match op with 751 | | Diff -> Some p0 752 | | Union | Xor -> if is_empty p0 then Some p1 else Some p0 753 | | Inter -> Some empty 754 | 755 | let bool_op_trivial_cases op p0 p1 = 756 | (* assert (not (is_empty p0) && not (is_empty p1)); *) 757 | let p0_min, p0_max = min_max p0 in 758 | let p1_min, p1_max = min_max p1 in 759 | let no_overlap = 760 | (P2.x p0_min > P2.x p1_max) || (P2.x p1_min > P2.x p0_max) || 761 | (P2.y p0_min > P2.y p1_max) || (P2.y p1_min > P2.y p0_max) 762 | in 763 | if not no_overlap then None else match op with 764 | | Diff -> Some p0 765 | | Inter -> Some empty 766 | | Union | Xor -> 767 | Some (of_rings (List.rev_append (List.rev p0.rings) p1.rings)) 768 | 769 | 770 | let bool_op_other_cases op p0 p1 = 771 | let evs, overlap_err = match Sweep.events op p0 p1 with 772 | | Ok evs -> evs, false | Error evs -> evs, true 773 | in 774 | let evs = Event.filter_and_sort evs in 775 | match Topology.find evs with 776 | | Ok _ as r -> r 777 | | Error (r, msg) -> 778 | if overlap_err 779 | then Error (r, `Edge_overlap) 780 | else Error (r, `Topology_panic msg) 781 | 782 | let bool_op op p0 p1 = match bool_op_empty_cases op p0 p1 with 783 | | Some r -> Ok (r, (* FIXME we need to compute the topo info *) []) 784 | | None -> 785 | match bool_op_trivial_cases op p0 p1 with 786 | | Some r -> Ok (r, (* FIXME we need to compute the topo info *) []) 787 | | None -> bool_op_other_cases op p0 p1 788 | 789 | type holes = int list list 790 | type bool_op_error = 791 | [ `Edge_overlap 792 | | `Topology_panic of string ] 793 | 794 | type bool_op_result = (t * holes, (t * holes) * bool_op_error) result 795 | let union p0 p1 = bool_op Union p0 p1 796 | let diff p0 p1 = bool_op Diff p0 p1 797 | let inter p0 p1 = bool_op Inter p0 p1 798 | let xor p0 p1 = bool_op Xor p0 p1 799 | -------------------------------------------------------------------------------- /src/kit/gg__pgon2.mli: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2022 The gg programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | (** 2D polygons. 7 | 8 | A polygon is defined by a list of {!Ring2.t}s. Polygon 9 | surface is determined by the even-odd rule. *) 10 | 11 | open Gg 12 | 13 | (** {1:polygons Polygons} *) 14 | 15 | type t 16 | (** The type for polygons. *) 17 | 18 | val of_rings : Gg__ring2.t list -> t 19 | (** [of_rings rs] is a polygon from the list of rings [rs]. *) 20 | 21 | val empty : t 22 | (** [empty] is an empty polygon. *) 23 | 24 | (** {1:props Properties} *) 25 | 26 | val rings : t -> Gg__ring2.t list 27 | (** [rings p] are the rings of [p]. *) 28 | 29 | val box : t -> Box2.t 30 | (** [box p] is a bounding box for the polygon. *) 31 | 32 | (** {1:predicates Predicates} *) 33 | 34 | val is_empty : t -> bool 35 | (** [is_empty p] is [true] iff [p] is empty. *) 36 | 37 | (** {1:bool Boolean operations} 38 | 39 | Boolean operations are implemented using 40 | {{:https://doi.org/10.1016/j.advengsoft.2013.04.004}this 41 | algorithm}. 42 | 43 | Input polygons can be concave and self-interesting the only 44 | constraint is that no two ring edges should overlap in a {e 45 | single} input polygon. The orientation of the rings does not 46 | matter for the algorithm it determines holes using the even-odd 47 | rule: any ring included in an odd number of rings bounds a 48 | hole. 49 | 50 | Overlap between input polygons is supported. *) 51 | 52 | type holes = int list list 53 | (** The type for the rings holds, one list per ring in the 54 | order of {!fold_contours}. The list has the position of holes in 55 | the order of {!fold_contours}. FIXME forget about that and 56 | return correctly oriented polygons. *) 57 | 58 | type bool_op_error = 59 | [ `Edge_overlap (** The input polygons have overlapping edges *) 60 | | `Topology_panic of string 61 | (** Internal error, please report the test case. *) ] 62 | 63 | type bool_op_result = (t * holes, (t * holes) * bool_op_error) result 64 | (** The type for boolean operation results. [Error (_, _, `Edge_overlap)] 65 | is returned if two contour edges overlap in a single input polygon. 66 | In that case there are two edges that overlap in either input polygon. In 67 | this case you should be suspicious about the result. 68 | 69 | The result polygon is a polygon whose surface can be determined 70 | both by the even oddrule and the non-zero winding rule 71 | (i.e. contours of holes are clockwise and other contours are 72 | counter clockwise). This means that the {{!Contour.area}signed 73 | area} of contours can be used to compute the resulting surface. 74 | 75 | {b FIXME.} 76 | {ul 77 | {- The result can contain contours that self intersect 78 | seems it only happens with [xor]. This likely affects surface 79 | computation.} 80 | {- Holes are not computed for now. Simply interpret 81 | the result with the even-odd rule.}} *) 82 | 83 | val union : t -> t -> bool_op_result 84 | (** [union p0 p1] is the union of [p0] and [p1]. *) 85 | 86 | val diff : t -> t -> bool_op_result 87 | (** [diff p0 p1] is [p0] minus [p1]. *) 88 | 89 | val inter : t -> t -> bool_op_result 90 | (** [inter p0 p1] is the intersection of [p0] and [p1]. *) 91 | 92 | val xor : t -> t -> bool_op_result 93 | (** [xor p0 p1] is the exclusive union of [p0] and [p1]. *) 94 | 95 | (**/**) 96 | (* This is exposed for [pgon_debug.ml] we should remove that at 97 | some point. *) 98 | 99 | type polygon = Subject | Clipping (* left and right argument of bool ops *) 100 | type overlap = (* For overlap information see §7.2 of the first paper. *) 101 | | No | Not_contributing | Same_inout | Different_inout 102 | 103 | type bool_op = Union | Diff | Inter | Xor 104 | 105 | module Event : sig 106 | type t = 107 | { polygon : polygon; 108 | pt : P2.t; 109 | mutable other : t; 110 | mutable is_left : bool; 111 | mutable overlap : overlap; 112 | mutable inout : bool; 113 | mutable other_poly_inout : bool; 114 | mutable in_result : bool; 115 | mutable below_in_result : t; 116 | mutable resort : bool; 117 | mutable sort_index : int; 118 | mutable contour_id : int; 119 | mutable result_inout : bool; } 120 | 121 | val pp_dump : Format.formatter -> t -> unit 122 | end 123 | 124 | module Sweep : sig 125 | val debug_stepper : bool_op -> t -> t -> 126 | (unit -> 127 | (Event.t option * Event.t * Event.t option * Event.t list) option) 128 | 129 | val debug_result : ?filtered:bool -> bool_op -> t -> t -> Event.t list 130 | end 131 | (**/**) 132 | 133 | (** {1:traversals Traversals} *) 134 | 135 | val fold_rings : (Gg__ring2.t -> 'a -> 'a) -> t -> 'a -> 'a 136 | (** [fold_rings f p acc] folds on the rings of [p]. *) 137 | -------------------------------------------------------------------------------- /src/kit/gg__ring2.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2022 The gg programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | open Gg 7 | 8 | (* Linear rings *) 9 | 10 | type t = P2.t list (* XXX maybe switch to arrays. *) 11 | let of_pts pts = pts 12 | let empty = [] 13 | 14 | (* Properties *) 15 | 16 | let pts = Fun.id 17 | let area = function 18 | | [] | [_] | [_; _] -> 0. 19 | | pts -> 20 | let a = ref 0. and acc = ref pts and last = ref false in 21 | while !acc <> [] do match !acc with 22 | | p0 :: (p1 :: _ as acc') -> 23 | (* XXX this is not robust see p. 245 of 24 | Geometric data structures for computer graphics. *) 25 | let x0 = P2.x p0 and y0 = P2.y p0 in 26 | let x1 = P2.x p1 and y1 = P2.y p1 in 27 | let w = (x0 *. y1) -. (x1 *. y0) in 28 | a := !a +. w; 29 | acc := acc'; 30 | | [p] -> 31 | if !last then acc := [] else (last := true ; acc := [p; List.hd pts]) 32 | | [] -> assert false 33 | done; 34 | 0.5 *. !a 35 | 36 | let centroid = function 37 | | [] | [_] | [_; _] -> P2.o 38 | | pts -> 39 | (* https://paulbourke.net/geometry/polygonmesh/centroid.pdf *) 40 | let cx = ref 0. and cy = ref 0. and a = ref 0. in 41 | let acc = ref pts and last = ref false in 42 | while !acc <> [] do match !acc with 43 | | p0 :: (p1 :: _ as acc') -> 44 | let x0 = P2.x p0 and y0 = P2.y p0 in 45 | let x1 = P2.x p1 and y1 = P2.y p1 in 46 | let w = (x0 *. y1) -. (x1 *. y0) in 47 | a := !a +. w; 48 | cx := !cx +. (x0 +. x1) *. w; 49 | cy := !cy +. (y0 +. y1) *. w; 50 | acc := acc'; 51 | | [p] -> 52 | if !last then acc := [] else (last := true ; acc := [p; List.hd pts]) 53 | | [] -> assert false 54 | done; 55 | let a = 0.5 *. !a in 56 | let wa = 1. /. (6. *. a) in 57 | P2.v (wa *. !cx) (wa *. !cy) 58 | 59 | let box pts = 60 | if pts = [] then Box2.empty else 61 | let rec loop xmin ymin xmax ymax = function (* XXX rewrite, this boxes *) 62 | | [] -> Box2.of_pts (V2.v xmin ymin) (V2.v xmax ymax) 63 | | pt :: pts -> 64 | let px = V2.x pt and py = V2.y pt in 65 | let xmin = Float.min xmin px and ymin = Float.min ymin py in 66 | let xmax = Float.max xmax px and ymax = Float.max ymax py in 67 | (loop[@tailcall]) xmin ymin xmax ymax pts 68 | in 69 | let fmax = Float.max_float and fmin = ~-. Float.max_float in 70 | loop fmax fmax fmin fmin pts 71 | 72 | (* Predicates *) 73 | 74 | let is_empty r = r = [] 75 | let mem pt = function 76 | | [] -> false 77 | | [p] -> V2.equal pt p 78 | | p :: ps -> 79 | let[@inline] is_inside inside x y xj yj xi yi = 80 | if ((yi <= y && y < yj) || (yj <= y && y < yi)) && 81 | (x < (xj -. xi) *. (y -. yi) /. (yj -. yi) +. xi) 82 | then not inside else inside 83 | in 84 | let rec loop first inside x y xj yj = function 85 | | [] -> 86 | let xi = V2.x first and yi = V2.y first in 87 | (is_inside[@inlined]) inside x y xj yj xi yi 88 | | p :: ps -> 89 | let xi = V2.x p and yi = V2.y p in 90 | let inside = (is_inside[@inlined]) inside x y xj yj xi yi in 91 | loop first inside x y xi yi ps 92 | in 93 | loop p false (V2.x pt) (V2.y pt) (V2.x p) (V2.y p) ps 94 | 95 | (* Transforming *) 96 | 97 | let swap_orientation pts = List.rev pts 98 | 99 | (* Traversals *) 100 | 101 | let fold_pts f c acc = List.fold_left (Fun.flip f) acc c 102 | let fold_segs f c acc = match c with 103 | | [] -> acc 104 | | [p] -> f p p acc 105 | | p :: (_ :: _ as ps) -> 106 | let rec loop f acc first prev = function 107 | | [] -> f prev first acc 108 | | p :: ps -> (loop[@tailcall]) f (f prev p acc) first p ps 109 | in 110 | loop f acc p p ps 111 | -------------------------------------------------------------------------------- /src/kit/gg__ring2.mli: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2022 The gg programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | (** 2D linear rings. 7 | 8 | Linear rings are closed lists of straight segments. They may 9 | self-intersect. 10 | 11 | Rings are oriented using the right-hand rule. Counterclockwise 12 | rings bound a positive surface and clockwise ones a negative one 13 | (holes). 14 | 15 | Rings may self-interesect and be degenerate when made of less than 16 | three points. *) 17 | 18 | open Gg 19 | 20 | (** {1:linear_rings Linear rings} *) 21 | 22 | type t 23 | (** The type for linear rings. *) 24 | 25 | val of_pts : P2.t list -> t 26 | (** [of_pts pts] is a linear ring defined by points [pts]. Any two 27 | consecutive points of [pts] defines a segment of the ring. The 28 | last point is connected to the first one. *) 29 | 30 | val empty : t 31 | (** [empty] is an empty ring. *) 32 | 33 | (** {1:props Properties} *) 34 | 35 | val pts : t -> P2.t list 36 | (** [pts r] is the list of points of [r]. See {!of_pts}. *) 37 | 38 | val area : t -> float 39 | (** [area r] is the signed area of the ring [r]. You may be suprised 40 | by results on self-intersecting rings. Returns [0.] on degenerate 41 | rings. *) 42 | 43 | val centroid : t -> P2.t 44 | (** [centroid r] is the 45 | {{:https://paulbourke.net/geometry/polygonmesh/centroid.pdf} 46 | centroid} of [r]. Returns {!P2.o} on degenerate rings. *) 47 | 48 | val box : t -> Box2.t 49 | (** [box r] is the bounding box of [r]. This is {!Box2.empty} if 50 | {!is_empty}[ r] is [true]. *) 51 | 52 | (** {1:predicates Predicates} *) 53 | 54 | val is_empty : t -> bool 55 | (** [is_empty r] is [true] iff [r] is empty, that is if has no points. *) 56 | 57 | val mem : P2.t -> t -> bool 58 | (** [mem pt r] is [true] iff [pt] is inside the ring [r]. *) 59 | 60 | (** {1:transforming Transforming} *) 61 | 62 | val swap_orientation : t -> t 63 | (** [swap_orientation r] turns counterclockwise rings into clockwise 64 | ones and vice versa. *) 65 | 66 | (** {1:traversals Traversals} *) 67 | 68 | val fold_pts : (P2.t -> 'a -> 'a) -> t -> 'a -> 'a 69 | (** [fold_pts f r acc] is the result of folding [f] with [acc] on the 70 | points of [r]. This is [acc] if [c] is empty. *) 71 | 72 | val fold_segs : (P2.t -> P2.t -> 'a -> 'a) -> t -> 'a -> 'a 73 | (** [fold_segs f r acc] is the result of folding [f] with [acc] on the 74 | segments of [r]. This is [acc] if [r] is empty, and calls [f p p] 75 | on degenerate singleton rings made of a single point. *) 76 | -------------------------------------------------------------------------------- /src/kit/gg_kit.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2022 The gg programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | [@@@alert "-unstable"] 7 | module Color_scheme = Gg__color_scheme 8 | module Ring2 = Gg__ring2 9 | module Pgon2 = Gg__pgon2 10 | module Field2 = Gg__field2 11 | [@@@alert "+unstable"] 12 | -------------------------------------------------------------------------------- /src/kit/gg_kit.mli: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2022 The gg programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | (** Geometry and graphics toolkit. *) 7 | 8 | (** {1:unstable Unstable} 9 | 10 | These interfaces are not stabilized or their implementation 11 | is not entirely satisfactory, read the docs. *) 12 | 13 | [@@@alert "-unstable"] 14 | module Color_scheme = Gg__color_scheme 15 | module Ring2 = Gg__ring2 16 | module Pgon2 = Gg__pgon2 17 | module Field2 = Gg__field2 18 | [@@@alert "+unstable"] 19 | -------------------------------------------------------------------------------- /src/kit/gg_kit.mllib: -------------------------------------------------------------------------------- 1 | Gg_kit 2 | Gg__ring2 3 | Gg__pgon2 4 | Gg__field2 5 | Gg__color_scheme 6 | -------------------------------------------------------------------------------- /src/top/gg_top.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2013 The gg programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | let () = ignore (Toploop.use_file Format.err_formatter "gg_top_init.ml") 7 | -------------------------------------------------------------------------------- /src/top/gg_top.mllib: -------------------------------------------------------------------------------- 1 | Gg_top -------------------------------------------------------------------------------- /src/top/gg_top_init.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2013 The gg programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | open Gg;; 7 | 8 | #install_printer V2.pp;; 9 | #install_printer V3.pp;; 10 | #install_printer V4.pp;; 11 | #install_printer M2.pp;; 12 | #install_printer M3.pp;; 13 | #install_printer M4.pp;; 14 | #install_printer Box1.pp;; 15 | #install_printer Box2.pp;; 16 | #install_printer Box3.pp;; 17 | #install_printer Raster.pp;; 18 | #install_printer Raster.Sample.pp_format;; 19 | -------------------------------------------------------------------------------- /test/benchmark.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2013 Edwin Török. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | open Gg 7 | 8 | let rand_rgb () = 9 | let r = Float.random ~min:0. ~len:1. () in 10 | let g = Float.random ~min:0. ~len:1. () in 11 | let b = Float.random ~min:0. ~len:1. () in 12 | V4.v r g b 1. 13 | 14 | let rand_lch_ab () = 15 | let l = Float.random ~min:0. ~len:100. () in 16 | let c = Float.random ~min:0. ~len:181.02 () in 17 | let h = Float.random ~min:0. ~len:Float.two_pi () in 18 | V4.v l c h 1. 19 | 20 | let rand_lab () = 21 | let l = Float.random ~min:0. ~len:100. () in 22 | let a = Float.random ~min:(-128.) ~len:(127. +. 128.) () in 23 | let b = Float.random ~min:(-128.) ~len:(127. +. 128.) () in 24 | V4.v l a b 1. 25 | 26 | let srgb_to_rgb () = Color.of_srgb (rand_rgb ()) 27 | let rgb_to_srgb () = Color.to_srgb (rand_rgb ()) 28 | let rgb_to_lab () = Color.to_lab (rand_rgb ()) 29 | let rgb_to_lch_ab () = Color.to_lch_ab (rand_rgb ()) 30 | let lch_ab_to_rgb () = Color.of_lch_ab (rand_lch_ab ()) 31 | let lab_to_rgb () = Color.of_lab (rand_lab ()) 32 | 33 | let () = 34 | Unmark_cli.main "gg" @@ 35 | Unmark.[ 36 | bench "sRGB -> RGB" srgb_to_rgb; 37 | bench "RGB -> sRGB" rgb_to_srgb; 38 | bench "RGB -> LAB" rgb_to_lab; 39 | bench "RGB -> LCH_AB" rgb_to_lch_ab; 40 | bench "LCH_AB -> RGB" lch_ab_to_rgb; 41 | bench "LAB -> RGB" lab_to_rgb; 42 | ] 43 | -------------------------------------------------------------------------------- /test/checkm.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2013 The gg programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | type 'a printer = Format.formatter -> 'a -> unit 7 | type 'a gen = (int -> Random.State.t -> 'a) * 'a printer 8 | let (>>) x f = f x 9 | 10 | module Test = struct 11 | 12 | module Log = struct 13 | type arg = unit printer 14 | type id = string option 15 | type backtrace = string list 16 | type cmp = [ `Gt | `Geq | `Lt | `Leq | `Eq | `Neq | `Peq | `Pneq] 17 | type labels = (string * int) list 18 | type failure = [ 19 | | `Exn_uncaught of id * exn * arg option 20 | | `Exn_none of id * arg option * arg option 21 | | `Comparison of id * cmp * (arg * arg) option 22 | | `Holds of id * arg option 23 | | `For_all of id * int * (arg option * failure * backtrace) list 24 | * labels option 25 | | `Other of string ] 26 | 27 | type murder = [ 28 | | `For_all of id * int * labels option 29 | | `Other of string ] 30 | 31 | type run_info = 32 | { run_test_count : int; 33 | run_fail_stop : bool; 34 | run_verbose : int; 35 | run_gen_seed : int; 36 | run_gen_size : int; 37 | run_gen_kill : int; 38 | run_gen_success : int; 39 | run_gen_falsifiers : int; } 40 | 41 | type run_result = 42 | { run_time : float; 43 | run_okay : int; 44 | run_fail : int; 45 | run_kill : int; 46 | run_skip : int; 47 | run_todo : int } 48 | 49 | type test_info = 50 | { test_name : string; 51 | test_num : int; 52 | (* test_seed : int *) } 53 | 54 | type check_info = 55 | { check_id : string; 56 | check_num : int } 57 | 58 | type test_result = [ 59 | | `Okay of float 60 | | `Fail of failure * backtrace 61 | | `Kill of murder * backtrace 62 | | `Skip of string * backtrace 63 | | `Todo of string * backtrace ] 64 | 65 | type event = [ 66 | | `No_exec of string list 67 | | `Run_start 68 | | `Run_end of run_result 69 | | `Test_start of test_info 70 | | `Test_end of test_info * test_result 71 | | `Print of arg ] 72 | 73 | (* Pretty print paragraphs. *) 74 | 75 | let r_paragraphs = Str.regexp "[ \t]*\n[ \t]*\n[ \n\t]*" 76 | let r_words = Str.regexp "[ \t]+\\|[ \t]*\n[ \t]*" 77 | let paragraphs s = (* paragraphs from string. *) 78 | let paragraphs = Str.split r_paragraphs s in 79 | List.map (Str.split r_words) paragraphs 80 | 81 | let rec pp_list pp_sep pp_v ppf = function 82 | | v :: l -> 83 | pp_v ppf v; 84 | if (l <> []) then (pp_sep ppf (); pp_list pp_sep pp_v ppf l) 85 | | [] -> () 86 | 87 | let pp_paragraphs ppf s = 88 | let words ppf wl = 89 | Format.fprintf ppf "@["; 90 | pp_list Format.pp_print_space Format.pp_print_string ppf wl; 91 | Format.fprintf ppf "@]"; 92 | in 93 | let paras = pp_list (fun pp () -> Format.fprintf ppf "@ @ ") words in 94 | Format.fprintf ppf "@[%a@]" paras (paragraphs s) 95 | 96 | (* Misc pretty printers. *) 97 | 98 | let prf ppf fmt = Format.fprintf ppf fmt (* short cut. *) 99 | 100 | let cmp_to_string = function 101 | | `Lt -> "<" | `Leq -> "<=" | `Eq -> "=" | `Neq -> "<>" 102 | | `Gt -> ">" | `Geq -> ">=" | `Peq -> "==" | `Pneq -> "!=" 103 | 104 | let pp_id ppf = function None -> () | Some v -> prf ppf "%s: " v 105 | let pp_backtrace ppf = function 106 | | [] -> 107 | prf ppf "%a" pp_paragraphs 108 | "No stack trace, did you compile and link with -g ? Is the \ 109 | last check of the sequence C.success ? are you using bytecode ?" 110 | | bt -> 111 | prf ppf "@[%a@]" 112 | (pp_list Format.pp_print_space Format.pp_print_string) bt 113 | 114 | let pp_arg ppf v = match v with 115 | | None -> () | Some v -> prf ppf "@[@ on@ value@ %a@]" v () 116 | 117 | (* Pretty printing failures. *) 118 | 119 | let rec pp_falsifiers ri ppf falsifiers = 120 | let pp_arg' ppf v = match v with 121 | | None -> () | Some v -> prf ppf "@[On@ value@ %a@]@ " v () 122 | in 123 | let pp_case ppf (arg, f, bt) = prf ppf "@[%a%a@ %a@]@ " 124 | pp_arg' arg (pp_failure ri) f pp_backtrace bt 125 | in 126 | prf ppf "@[%a@]" (pp_list Format.pp_print_space pp_case) falsifiers 127 | 128 | and pp_failure ri ppf f = 129 | let pr fmt = prf ppf fmt in 130 | match f with 131 | | `Exn_uncaught (id, e, v) -> pr "@[%aUncaught@ exception@ %s%a.@]" 132 | pp_id id (Printexc.to_string e) pp_arg v 133 | | `Exn_none (id, a, r) -> 134 | let pr_ret ppf = function None -> prf ppf "@ a@ value" 135 | | Some v -> prf ppf " %a" v () 136 | in 137 | pr "@[%aExpected@ an@ exception%a@ but%a@ was@ returned.@]" pp_id id 138 | pp_arg a pr_ret r 139 | | `Comparison (id, cmp, v) -> 140 | begin match v with 141 | | None -> pr "@[%aComparison@ predicate %s@ is@ false.@]" 142 | pp_id id (cmp_to_string cmp) 143 | | Some (v, v') -> pr "@[%a%a %s@ %a@ is@ false.@]" 144 | pp_id id v () (cmp_to_string cmp) v' () 145 | end 146 | | `Holds (id, v) -> 147 | pr "@[%aPredicate@ is@ false%a.@]" pp_id id pp_arg v 148 | | `For_all (id, okay, falsifiers, labels) -> 149 | pr "@[@[%aFor@ all@ fails@ after@ %d/%d@ successes.@]@ %a@]" 150 | pp_id id okay ri.run_gen_success (pp_falsifiers ri) falsifiers 151 | | `Other s -> pr "@[%a@]" pp_paragraphs s 152 | 153 | (* Pretty print murders *) 154 | 155 | let pp_murder ri ppf m = 156 | let pr fmt = prf ppf fmt in 157 | match m with 158 | | `For_all (id, okay, labels) -> 159 | pr "@[For all@ was@ killed, %d/%d@ cases@ passed@ after %d@ \ 160 | generations.@]" 161 | okay ri.run_gen_success ri.run_gen_kill 162 | | `Other s -> pr "@[%a@]" pp_paragraphs s 163 | 164 | (* Pretty print test ends *) 165 | 166 | let min_time = 0.001 (* timings < min_time are not reported. *) 167 | 168 | let pp_test_end ri i ppf res = 169 | let pr fmt = prf ppf fmt in 170 | let pr_time ppf t = if t >= min_time then prf ppf "@ (%.4gs)" t in 171 | match res with 172 | | `Okay t -> 173 | pr "@[[okay] @[%s%a@]@]" i.test_name pr_time t 174 | | `Skip (s, bt) -> 175 | pr "@[[skip] @[%s@ %a@ %a@]@]" 176 | i.test_name pp_paragraphs s pp_backtrace bt 177 | | `Todo (s, bt) -> 178 | pr "@[[todo] @[%s@ %a@ %a@]@]" 179 | i.test_name pp_paragraphs s pp_backtrace bt 180 | | `Kill (m, bt) -> 181 | pr "@[[kill] @[%s@ %a@ %a@]@]" 182 | i.test_name (pp_murder ri) m pp_backtrace bt 183 | | `Fail (f, bt) -> 184 | pr "@[[fail] @[%s@ %a@ %a@]@]" 185 | i.test_name (pp_failure ri) f pp_backtrace bt 186 | 187 | (* Loggers. *) 188 | 189 | let batch_log ppf ri e = 190 | let pr fmt = prf ppf fmt in 191 | match e with 192 | | `No_exec l -> 193 | let pr_l = pp_list Format.pp_print_space Format.pp_print_string in 194 | if l <> [] then pr "@[%a@ @]" pr_l l 195 | | `Run_start -> 196 | if ri.run_verbose < 1 then () else 197 | pr "@[Running %d tests@ with@ random seed %d@ and@ size hint %d.@]@." 198 | ri.run_test_count ri.run_gen_seed ri.run_gen_size; 199 | | `Run_end r -> 200 | if ri.run_verbose < 1 then () else 201 | let result r = if r.run_fail = 0 then "Success" else "FAILURE" in 202 | pr "@.@[%d succeded,@ %d failed,@ %d killed,@ %d skipped,\ 203 | @ %d todo@]@." 204 | r.run_okay r.run_fail r.run_kill r.run_skip r.run_todo; 205 | pr "@[%s@ " (result r); 206 | if (r.run_time >= min_time) then pr "in@ %.4gs@ " r.run_time; 207 | pr "with@ random@ seed %d@ and@ size hint %d.@]@." 208 | ri.run_gen_seed ri.run_gen_size 209 | | `Test_start i -> () 210 | | `Test_end (i, res) -> pr "%a@." (pp_test_end ri i) res 211 | | `Print v -> pr "%a" v () 212 | 213 | let term_log ppf ri e = 214 | let pr fmt = prf ppf fmt in 215 | match e with 216 | | `Test_start i -> 217 | pr "@[@<0>%s[@<0>%sexec@<0>%s] @[(%d/%d)@ %s@]@?" 218 | "\x1B7" "\x1B[5m" "\x1B[0m" i.test_num ri.run_test_count i.test_name 219 | | `Test_end r -> 220 | pr "@<0>%s" "\x1B8\x1B[K"; (* kill the line. *) 221 | begin match r with 222 | | (i, `Fail (f, bt)) -> 223 | pr "@<0>%s[fail]@<0>%s @[%s@ %a@ %a@]@\n@." 224 | "\x1B[7m" "\x1B[0m" i.test_name (pp_failure ri) f pp_backtrace 225 | bt 226 | | _ -> batch_log ppf ri e 227 | end 228 | | e -> batch_log ppf ri e 229 | end 230 | 231 | (* Tests *) 232 | 233 | type log = Log.run_info -> Log.event -> unit 234 | type run = 235 | { info : Log.run_info; 236 | log : log; 237 | rstate : Random.State.t; 238 | mutable tnum : int; (* current test number in the list of tests. *) 239 | mutable okay : int; 240 | mutable fail : int; 241 | mutable kill : int; 242 | mutable skip : int; 243 | mutable todo : int; } 244 | 245 | type t = string * (run -> unit) 246 | 247 | let create n f = n, (fun t -> ignore (f t)) 248 | let name (n, _) = n 249 | let func (_, f) = f 250 | 251 | (* Global test list *) 252 | 253 | let list : t list ref = ref [] 254 | let add_test n f = list := (create n f) :: !list 255 | 256 | (* Stopping tests *) 257 | 258 | exception Fail of Log.failure 259 | exception Kill of Log.murder 260 | exception Skip of string 261 | exception Todo of string 262 | 263 | let fail s = raise (Fail (`Other s)) 264 | let kill s = raise (Kill (`Other s)) 265 | let skip s = raise (Skip s) 266 | let todo s = raise (Todo s) 267 | 268 | (* Loggers *) 269 | let term_log = Log.term_log 270 | let batch_log = Log.batch_log 271 | 272 | (* Runs *) 273 | 274 | type run_conf = 275 | { selectors : string list; 276 | sort : (string -> string -> int) option; 277 | no_exec : bool; 278 | fail_stop : bool; 279 | verbose : int; 280 | gen_seed : int option; 281 | gen_size : int; 282 | gen_kill : int option; 283 | gen_success : int; 284 | gen_falsifiers : int } 285 | 286 | let run_conf = 287 | { selectors = []; sort = Some Stdlib.compare; no_exec = false; 288 | fail_stop = false; verbose = 1; gen_seed = None; gen_size = 100; 289 | gen_kill = None; gen_success = 1000; gen_falsifiers = 3; } 290 | 291 | let select_tests prefixes tests = match prefixes with 292 | | [] -> tests, List.length tests 293 | | l -> 294 | let any l = String.concat "\\|" l in 295 | let prefix p = (Str.quote p) ^ ".*" in 296 | let r = Str.regexp_case_fold (any (List.rev_map prefix l)) in 297 | let matches (n, _) = 298 | Str.string_match r n 0 && Str.matched_string n = n 299 | in 300 | let add ((l, n) as acc) t = if matches t then (t :: l, n+1) else acc in 301 | List.fold_left add ([], 0) tests 302 | 303 | let sort_tests ?(decr = false) sort tests = match sort with 304 | | None -> tests 305 | | Some cmp -> 306 | let test_cmp = 307 | if decr then fun (n, _) (n', _) -> -1 * cmp n n' else 308 | fun (n, _) (n', _) -> cmp n n' 309 | in 310 | List.sort test_cmp tests 311 | 312 | let create_run log conf test_count = 313 | let rseed = match conf.gen_seed with 314 | | Some s -> s 315 | | None -> (* generate a random seed. *) 316 | let s = Random.State.make_self_init () in 317 | Random.State.bits s 318 | in 319 | let kill = match conf.gen_kill with 320 | | None -> 4 * conf.gen_success | Some v -> v 321 | in 322 | let info = { Log.run_test_count = test_count; 323 | run_fail_stop = conf.fail_stop; 324 | run_verbose = conf.verbose; 325 | run_gen_seed = rseed; 326 | run_gen_size = conf.gen_size; 327 | run_gen_kill = kill; 328 | run_gen_success = conf.gen_success; 329 | run_gen_falsifiers = conf.gen_falsifiers } 330 | in 331 | let rstate = Random.State.make [| rseed |] in 332 | { info = info; log = log; rstate = rstate; tnum = 0; okay = 0; 333 | fail = 0; kill = 0; skip = 0; todo = 0; } 334 | 335 | (* Note, it would have been nice to be able to get and possibly 336 | report the seed for a single test but Random doesn't provide 337 | that. *) 338 | 339 | let r_newline = Str.regexp "\n" 340 | let r_checkm = Str.regexp ".*checkm.ml" 341 | let split_trace ?(full = false) backtrace = (* Split the backtraces (Grrr). *) 342 | let stack = Str.split r_newline backtrace in 343 | let no_ptest s = not (Str.string_match r_checkm s 0) in 344 | if full then stack else List.filter no_ptest stack 345 | 346 | exception Fail_stop (* to stop after first failure. *) 347 | 348 | let run_test r (n, f) = 349 | let start = Sys.time () in 350 | r.tnum <- r.tnum + 1; 351 | let info = { Log.test_name = n; test_num = r.tnum; } in 352 | r.log r.info (`Test_start info); 353 | let result = 354 | try ignore (f r); r.okay <- r.okay + 1; `Okay (Sys.time () -. start) with 355 | | e -> 356 | let b = Printexc.get_backtrace () in 357 | match e with 358 | | Skip s -> r.skip <- r.skip + 1; `Skip (s, split_trace b) 359 | | Todo s -> r.todo <- r.todo + 1; `Todo (s, split_trace b) 360 | | Kill s -> r.kill <- r.kill + 1; `Kill (s, split_trace b) 361 | | Fail f -> r.fail <- r.fail + 1; `Fail (f, split_trace b) 362 | | e -> 363 | r.fail <- r.fail + 1; `Fail (`Exn_uncaught (None, e, None), 364 | split_trace b) 365 | in 366 | r.log r.info (`Test_end (info, result)); 367 | if r.info.Log.run_fail_stop && r.fail > 0 then raise Fail_stop 368 | 369 | let no_exec log conf tests = 370 | let tests, test_count = select_tests conf.selectors tests in 371 | let names = List.rev_map fst (sort_tests ~decr:true conf.sort tests) in 372 | let r = create_run log conf test_count in 373 | r.log r.info (`No_exec names); 374 | `Ok 375 | 376 | let run log conf tests = 377 | if conf.no_exec then no_exec log conf tests else 378 | let start = Sys.time () in 379 | let tests, test_count = 380 | let tests, count = select_tests conf.selectors tests in 381 | sort_tests conf.sort tests, count 382 | in 383 | let r = create_run log conf test_count in 384 | r.log r.info `Run_start; 385 | Printexc.record_backtrace true; 386 | (try List.iter (run_test r) tests; with Fail_stop -> ()); 387 | r.log r.info (`Run_end { Log.run_time = Sys.time () -. start; 388 | run_okay = r.okay; 389 | run_fail = r.fail; 390 | run_kill = r.kill; 391 | run_skip = r.skip; 392 | run_todo = r.todo; }); 393 | if r.fail = 0 then `Ok else `Fail 394 | 395 | let runf ?log conf f = failwith "TODO" 396 | 397 | (* Command line options *) 398 | 399 | let log_args logger = [ 400 | "-batch", Arg.Unit (fun () -> logger := batch_log) , 401 | "batch mode, does not output terminal control sequences" ] 402 | 403 | let run_conf_args a = 404 | let u a' = a := a' in [ 405 | "-select", Arg.String (fun s -> u { !a with selectors = s::!a.selectors }), 406 | ", execute only tests whose name matches "; 407 | "-no-exec", Arg.Unit (fun () -> u { !a with no_exec = true }), 408 | "don't execute the tests, only print their names"; 409 | "-fail-stop", Arg.Unit (fun () -> u { !a with fail_stop = true }), 410 | "stop on first failed test"; 411 | "-verbose", Arg.Int (fun v -> u { !a with verbose = v }), 412 | " make the output more verbose (defaults to 1)."; 413 | "-seed", Arg.Int (fun s -> u { !a with gen_seed = Some s }), 414 | ", random seed (auto-generated if unspecified)."; 415 | "-size", Arg.Int (fun s -> u { !a with gen_size = s }), 416 | ", hint size for generated cases (defaults to 100)"; 417 | "-kill", Arg.Int (fun k -> u { !a with gen_kill = Some k }), 418 | ", generated cases before killing (defaults to 4 * success)."; 419 | "-success", Arg.Int (fun s -> u { !a with gen_success = s }), 420 | ", succeeding cases before success (defaults to 1000)"; 421 | "-falsifiers", Arg.Int (fun f -> u { !a with gen_falsifiers = f }), 422 | "number of failing cases reported (defaults to 3)"; ] 423 | end 424 | 425 | type test = Test.t 426 | 427 | module C = struct 428 | 429 | type check = Test.run -> Test.run 430 | 431 | let fail f = raise (Test.Fail f) 432 | let arg pr v = fun ppf () -> pr ppf v 433 | let arg_of_pr pr v = match pr with None -> None | Some pr -> Some (arg pr v) 434 | let neg p = fun x -> not (p x) 435 | let success r = r 436 | let holds ?id ?pr p v r = 437 | if p v then r else fail (`Holds (id, arg_of_pr pr v)) 438 | 439 | let for_all ?id ?pr ?classify ?(cond = fun _ -> true) (g, gpr) check r = 440 | let total = ref 0 in 441 | let okay = ref 0 in 442 | let failc = ref 0 in 443 | let falsifiers = ref [] in 444 | while (!okay < r.Test.info.Test.Log.run_gen_success && 445 | !total < r.Test.info.Test.Log.run_gen_kill && 446 | !failc < r.Test.info.Test.Log.run_gen_falsifiers) 447 | do 448 | let v = g r.Test.info.Test.Log.run_gen_size r.Test.rstate in 449 | if (cond v) then begin 450 | try check v r; incr okay; with 451 | | Test.Fail f -> 452 | let b = Printexc.get_backtrace () in 453 | let f = (arg_of_pr pr v), f, (Test.split_trace b) in 454 | falsifiers := f :: !falsifiers; 455 | incr failc 456 | end; 457 | incr total 458 | done; 459 | let labels = None in 460 | if !failc <> 0 then fail (`For_all (id, !okay, !falsifiers, labels)) else 461 | if !total = r.Test.info.Test.Log.run_gen_kill then 462 | raise (Test.Kill (`For_all (id, !okay, labels))) 463 | else 464 | r 465 | 466 | let no_raise ?id ?pr f v r = 467 | try ignore (f v); r with 468 | | e -> fail (`Exn_uncaught (id, e, arg_of_pr pr v)) 469 | 470 | let raises ?id ?pr ?prr ?(exn = fun _ -> true) f v r = 471 | let res = ref None in 472 | begin try res := Some (f v) 473 | with e -> if not (exn e) then fail (`Exn_uncaught (id, e, arg_of_pr pr v)) 474 | end; 475 | match !res with 476 | | None -> r 477 | | Some res -> fail (`Exn_none (id, arg_of_pr pr v, arg_of_pr prr res)) 478 | 479 | let raises_failure ?id ?pr ?prr f v t = 480 | let exn = function Failure _ -> true | _ -> false in 481 | raises ~exn ?id ?pr ?prr f v t 482 | 483 | let raises_invalid_arg ?id ?pr ?prr f v t = 484 | let exn = function Invalid_argument _ -> true | _ -> false in 485 | raises ~exn ?id ?pr ?prr f v t 486 | 487 | let catch c f v r = try c r with Test.Fail _ -> ignore (f v); r 488 | 489 | let log pr v r = r.Test.log r.Test.info (`Print (arg pr v)); r 490 | 491 | module Order = struct 492 | type 'a cmp = ?cmp:('a -> 'a -> int) -> ?id:string -> ?pr:'a printer -> 'a 493 | -> 'a -> check 494 | 495 | let cmp_failure ?id ?pr x c y = match pr with 496 | | None -> `Comparison (id, c, None) 497 | | Some pr -> `Comparison (id, c, Some (arg pr x, arg pr y)) 498 | 499 | 500 | let compare ?(cmp = Stdlib.compare) ?id ?pr x c y r = 501 | let success = match cmp x y with 502 | | 0 -> (match c with `Eq | `Geq | `Leq -> true | _ -> false) 503 | | 1 -> (match c with `Gt | `Geq | `Neq-> true | _ -> false) 504 | | -1 -> (match c with `Lt | `Leq | `Neq -> true | _ -> false) 505 | | _ -> assert false 506 | in 507 | if success then r else fail (cmp_failure ?id ?pr x c y) 508 | 509 | let (=) ?cmp ?id ?pr x y r = compare ?id ?pr ?cmp x `Eq y r 510 | let (<>) ?cmp ?id ?pr x y r = compare ?id ?pr ?cmp x `Neq y r 511 | let (<) ?cmp ?id ?pr x y r = compare ?id ?pr ?cmp x `Lt y r 512 | let (<=) ?cmp ?id ?pr x y r = compare ?id ?pr ?cmp x `Leq y r 513 | let (>) ?cmp ?id ?pr x y r = compare ?id ?pr ?cmp x `Gt y r 514 | let (>=) ?cmp ?id ?pr x y r = compare ?id ?pr ?cmp x `Geq y r 515 | 516 | let pequal ?id ?pr x c y r = match (x == y), c with 517 | | true, `Peq | false, `Pneq -> r 518 | | false, `Peq | true, `Pneq -> fail (cmp_failure ?id ?pr x c y) 519 | | _ -> assert false 520 | 521 | let (==) ?id ?pr x y r = pequal ?id ?pr x `Peq y r 522 | let (!=) ?id ?pr x y r = pequal ?id ?pr x `Pneq y r 523 | end 524 | 525 | module type Testable = sig 526 | type t 527 | val pp : Format.formatter -> t -> unit 528 | val compare : t -> t -> int 529 | end 530 | 531 | module type S = sig 532 | type t 533 | 534 | val holds : ?id:string -> (t -> bool) -> t -> check 535 | val for_all : ?id:string -> ?classify:(t -> string) -> ?cond:(t -> bool) -> 536 | t gen -> (t -> Test.run -> 'b) -> check 537 | 538 | val no_raise : ?id:string -> (t -> 'b) -> t -> check 539 | 540 | val raises : ?id:string -> ?prr:'b printer -> 541 | ?exn:(exn -> bool) -> (t -> 'b) -> t -> check 542 | 543 | val raises_failure : ?id:string -> ?prr:'b printer -> 544 | (t -> 'b) -> t -> check 545 | 546 | val raises_invalid_arg : ?id:string -> ?prr:'b printer -> 547 | (t -> 'b) -> t -> check 548 | 549 | val log : t -> check 550 | 551 | module Order : sig 552 | val (=) : ?id:string -> t -> t -> check 553 | val (<>) : ?id:string -> t -> t -> check 554 | val (<) : ?id:string -> t -> t -> check 555 | val (<=) : ?id:string -> t -> t -> check 556 | val (>) : ?id:string -> t -> t -> check 557 | val (>=) : ?id:string -> t -> t -> check 558 | val (==) : ?id:string -> t -> t -> check 559 | val (!=) : ?id:string -> t -> t -> check 560 | end 561 | end 562 | 563 | module Make (T : Testable) = struct 564 | type t = T.t 565 | let holds = holds ~pr:T.pp 566 | let for_all = for_all ~pr:T.pp 567 | let no_raise = no_raise ~pr:T.pp 568 | let raises = raises ~pr:T.pp 569 | let raises_failure = raises_failure ~pr:T.pp 570 | let raises_invalid_arg = raises_invalid_arg ~pr:T.pp 571 | let log = log T.pp 572 | module Order = struct 573 | let (=) ?id x y = Order.(=) ~cmp:T.compare ?id ~pr:T.pp x y 574 | let (<>) ?id x y = Order.(<>) ~cmp:T.compare ?id ~pr:T.pp x y 575 | let (<) ?id x y = Order.(<) ~cmp:T.compare ?id ~pr:T.pp x y 576 | let (<=) ?id x y = Order.(<=) ~cmp:T.compare ?id ~pr:T.pp x y 577 | let (>) ?id x y = Order.(>) ~cmp:T.compare ?id ~pr:T.pp x y 578 | let (>=) ?id x y = Order.(>=) ~cmp:T.compare ?id ~pr:T.pp x y 579 | let (==) ?id x y = Order.(==) ?id ~pr:T.pp x y 580 | let (!=) ?id x y = Order.(!=) ?id ~pr:T.pp x y 581 | end 582 | end 583 | 584 | module Special = struct 585 | 586 | module Bool = struct 587 | type t = bool 588 | let pp = Format.pp_print_bool 589 | let compare = Stdlib.compare 590 | end 591 | 592 | module Char = struct 593 | type t = char 594 | let pp ppf c = Format.fprintf ppf "%C" c 595 | let compare = Stdlib.compare 596 | end 597 | 598 | module Int = struct 599 | type t = int 600 | let pp = Format.pp_print_int 601 | let compare = Stdlib.compare 602 | end 603 | 604 | module Float = struct 605 | type t = float 606 | let pp = Format.pp_print_float 607 | let compare = Stdlib.compare 608 | end 609 | 610 | module String = struct 611 | type t = string 612 | let pp ppf s = Format.fprintf ppf "%S" s 613 | let compare = Stdlib.compare 614 | end 615 | 616 | module Cb = Make (Bool) 617 | module Cc = Make (Char) 618 | module Ci = Make (Int) 619 | module Cf = Make (Float) 620 | module Cs = Make (String) 621 | end 622 | end 623 | 624 | module Gen = struct 625 | let prf ppf fmt = Format.fprintf ppf fmt 626 | 627 | let pr (_, pr) = pr 628 | let gen (g, _) = g 629 | 630 | (* Base type *) 631 | 632 | let unit = (fun s rs -> ()), fun ppf () -> prf ppf "()" 633 | let const v pr = (fun s rs -> v), pr 634 | let bool = (fun s rs -> Random.State.bool rs), fun ppf v -> prf ppf "%B" v 635 | let uint ?(max = max_int) () = 636 | let g = 637 | if max < 0 then invalid_arg "negative max" else 638 | if max = max_int then fun s rs -> Random.State.bits rs else 639 | let bound = max + 1 in 640 | fun s rs -> Random.State.int rs bound 641 | in 642 | let pr ppf v = prf ppf "%d" v in 643 | g, pr 644 | 645 | 646 | (* Higher-order *) 647 | 648 | let option (gv, prv) = 649 | let g s rs = if Random.State.bool rs then None else (Some (gv s rs)) in 650 | let pr ppf = function 651 | | None -> prf ppf "None" 652 | | Some v -> prf ppf "@[<6>Some(%a)@]" prv v 653 | in 654 | g, pr 655 | 656 | (* Note, tuple generators do not enforce an order of evaluation. *) 657 | 658 | let t2 (g0, pr0) (g1, pr1) = 659 | let g s rs = g0 s rs, g1 s rs in 660 | let pr ppf (v0, v1) = prf ppf "@[<1>(%a,@ %a)@]" pr0 v0 pr1 v1 in 661 | g, pr 662 | 663 | let t3 (g0, pr0) (g1, pr1) (g2, pr2) = 664 | let g s rs = g0 s rs, g1 s rs, g2 s rs in 665 | let pr ppf (v0, v1, v2) = 666 | prf ppf "@[<1>(%a,@ %a,@ %a)@]" pr0 v0 pr1 v1 pr2 v2 in 667 | g, pr 668 | 669 | let t4 (g0, pr0) (g1, pr1) (g2, pr2) (g3, pr3) = 670 | let g s rs = g0 s rs, g1 s rs, g2 s rs, g3 s rs in 671 | let pr ppf (v0, v1, v2, v3) = 672 | prf ppf "@[<1>(%a,@ %a,@ %a,@ %a)@]" pr0 v0 pr1 v1 pr2 v2 pr3 v3 673 | in 674 | g, pr 675 | 676 | let t5 (g0, pr0) (g1, pr1) (g2, pr2) (g3, pr3) (g4, pr4) = 677 | let g s rs = g0 s rs, g1 s rs, g2 s rs, g3 s rs, g4 s rs in 678 | let pr ppf (v0, v1, v2, v3, v4) = 679 | prf ppf "@[<1>(%a,@ %a,@ %a,@ %a,@ %a)@]" 680 | pr0 v0 pr1 v1 pr2 v2 pr3 v3 pr4 v4 681 | in 682 | g, pr 683 | 684 | let t6 (g0, pr0) (g1, pr1) (g2, pr2) (g3, pr3) (g4, pr4) (g5, pr5) = 685 | let g s rs = g0 s rs, g1 s rs, g2 s rs, g3 s rs, g4 s rs, g5 s rs in 686 | let pr ppf (v0, v1, v2, v3, v4, v5) = 687 | prf ppf "@[<1>(%a,@ %a,@ %a,@ %a,@ %a,@ %a)@]" 688 | pr0 v0 pr1 v1 pr2 v2 pr3 v3 pr4 v4 pr5 v5 689 | in 690 | g, pr 691 | 692 | 693 | 694 | (* 695 | let const v = fun () -> v 696 | let bool = fun () -> Random.State.bool rstate 697 | 698 | 699 | let int ?(amax = max_int) = 700 | if amax < 0 then invalid_arg "negative max" else 701 | if amax = max_int then 702 | let rec aux () = 703 | let v = rint rstate () in 704 | if v = min_int then aux () else v 705 | in 706 | aux 707 | else 708 | let bound = (2 * amax) + 1 in 709 | if 0 < bound && bound < max_int then 710 | fun () -> -amax + Random.State.int rstate bound 711 | else 712 | let bound = Int32.add (Int32.mul 2l (Int32.of_int amax)) 1l in 713 | let min = Int32.of_int (-amax) in 714 | fun () -> Int32.to_int (Int32.add min (Random.State.int32 rstate bound)) 715 | 716 | let after_one = 1. +. epsilon_float 717 | let ufloat ?(max = max_float) = 718 | if max < 0. then invalid_arg "negative max" else 719 | fun () -> (Random.State.float rstate after_one) *. max 720 | 721 | let float ?(amax = max_float) = 722 | if amax < 0. then invalid_arg "negative max" else 723 | fun () -> (-1. +. (Random.State.float rstate after_one) *. 2.) *. amax 724 | 725 | let char = fun () -> Char.chr (Random.State.int rstate 256) 726 | 727 | let string ?(len = uint ~max:1000) ?(c = char) = 728 | fun () -> 729 | let l = len () in 730 | let s = String.create l in 731 | for i = 0 to l - 1 do s.[i] <- c () done; 732 | s 733 | 734 | 735 | let list ?(len = uint ~max:1000) g = fun () -> 736 | let rec aux i len l = if i = len then l else aux (i + 1) len (g () :: l) in 737 | aux 0 (len ()) [] 738 | 739 | let map f g = fun () -> f (g ()) 740 | 741 | let filter p g = 742 | let rec aux () = let v = g () in if p v then v else aux () in 743 | aux 744 | 745 | let choose gl = List.nth gl (Random.State.int rstate (List.length gl)) 746 | *) 747 | 748 | end 749 | -------------------------------------------------------------------------------- /test/checkm.mli: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2013 The gg programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | (** Unit testing with automatic case generators (or not). 7 | 8 | [Checkm] is a module to define tests and run them. It supports 9 | precise failure reports and automatic (e.g. randomized) test case 10 | generation. 11 | 12 | Consult the {{:#basics}basics}. 13 | 14 | Open the module to use it. 15 | 16 | {b Important.} The module and the sources of your tests must be 17 | compiled and linked with [-g] (tag sources and executables with 18 | [debug] for [ocamlbuild]) to get good backtraces. Bytecode 19 | backtraces are usually more precise than native ones. 20 | 21 | {e Version %%VERSION%% - %%EMAIL%% } 22 | 23 | {1:top } *) 24 | 25 | type test 26 | (** The type for tests. *) 27 | 28 | type 'a printer = Format.formatter -> 'a -> unit 29 | (** The type for value printers. *) 30 | 31 | type 'a gen = (int -> Random.State.t -> 'a) * 'a printer 32 | (** The type for value generators. *) 33 | 34 | val (>>) : 'a -> ('a -> 'b) -> 'b 35 | (** Sequencing operator. *) 36 | 37 | (** Unit tests. 38 | 39 | {1:top Tests} *) 40 | module Test : sig 41 | 42 | type run 43 | (** The type for tests runs. Holds 44 | information about a test run. *) 45 | 46 | type t = test 47 | (** The type for tests. *) 48 | 49 | val create : string -> (run -> 'b) -> test 50 | (** [create n f] creates a test with name [n] and testing function [f]. *) 51 | 52 | val name : test -> string 53 | (** [name t] is the name of [t]. *) 54 | 55 | val func : test -> (run -> unit) 56 | (** [func t] is the test function of [t]. *) 57 | 58 | (** {3:defaultlist Global test list} 59 | 60 | Many test programs just define a list of tests in a global variable. 61 | [Checkm] defines one for you. *) 62 | 63 | val list : test list ref 64 | (** [list] an initially empty global list of tests. *) 65 | 66 | val add_test : string -> (run -> 'b) -> unit 67 | (** [add_test n f] add the test [create n f] in front of {!list}. *) 68 | 69 | (** {1:fail Stopping tests} 70 | 71 | These functions can be called by test functions to stop a test 72 | in different ways. *) 73 | 74 | val fail : string -> 'a 75 | (** [fail reason] stops the current test and marks it as failed 76 | for the given [reason]. *) 77 | 78 | val kill : string -> 'a 79 | (** [kill reason] stops the current test and marks it as killed 80 | for the given [reason]. *) 81 | 82 | val skip : string -> 'a 83 | (** [skip reason] stops the current test and marks it as skipped 84 | for the given [reason]. *) 85 | 86 | val todo : string -> 'a 87 | (** [todo reason] stops the current test and marks it as to be done 88 | for the given [reason]. *) 89 | 90 | (** {1:run Runs} *) 91 | 92 | (** Types for implementing logs. *) 93 | module Log : sig 94 | 95 | type backtrace = string list 96 | type arg = unit printer 97 | (** The type for function arguments in failures. Invoking 98 | the printer with unit will print the argument on the 99 | formatter. *) 100 | 101 | type id = string option 102 | type cmp = [ `Gt | `Geq | `Lt | `Leq | `Eq | `Neq | `Peq | `Pneq] 103 | (** The type for comparisons. *) 104 | type labels = (string * int) list 105 | type murder = [ 106 | | `For_all of id * int * labels option 107 | | `Other of string ] 108 | 109 | 110 | type failure = [ 111 | | `Exn_uncaught of id * exn * arg option 112 | | `Exn_none of id * arg option * arg option 113 | | `Comparison of id * cmp * (arg * arg) option 114 | | `Holds of id * arg option 115 | | `For_all of id * int * (arg option * failure * backtrace) list * 116 | labels option 117 | | `Other of string ] 118 | 119 | type run_info = 120 | { run_test_count : int; (** Total number of tests in the run. *) 121 | run_fail_stop : bool; 122 | run_verbose : int; (** Hinted output verboseness. *) 123 | run_gen_seed : int; (** Random seed for the run. *) 124 | run_gen_size : int; (** Size hint for generated values. *) 125 | run_gen_kill : int; (** Maximal number of cases generated. *) 126 | run_gen_success : int; (** Number of cases to pass *) 127 | run_gen_falsifiers : int; (** Approximate number of falsifiers. *) } 128 | 129 | type run_result = 130 | { run_time : float; (** Time taken to run all the tests. *) 131 | run_okay : int; (** Number of successful tests. *) 132 | run_fail : int; (** Number of failed tests. *) 133 | run_kill : int; (** Number of killed tests. *) 134 | run_skip : int; (** Number of skipped tests. *) 135 | run_todo : int (** Number of tests to do. *) } 136 | 137 | type test_info = 138 | { test_name : string; (** Test name. *) 139 | test_num : int; (** Test number in the run. *) 140 | (* test_seed : int; (** Random seed for the test. *) *) } 141 | 142 | type test_result = [ 143 | | `Okay of float (** Time taken *) 144 | | `Fail of failure * backtrace 145 | | `Kill of murder * backtrace 146 | | `Skip of string * backtrace 147 | | `Todo of string * backtrace ] 148 | 149 | 150 | type event = [ 151 | | `No_exec of string list 152 | | `Run_start 153 | | `Run_end of run_result 154 | | `Test_start of test_info 155 | | `Test_end of test_info * test_result 156 | | `Print of arg ] 157 | 158 | val pp_paragraphs : Format.formatter -> string -> unit 159 | (** [pp_paragraphs fmt s] pretty prints the paragraphs in [s] on 160 | [fmt]. Paragraphs are words separated by two or more 161 | newlines ('\n'). Words are sequences of printable characters 162 | separated by a sequence of white space that do not contain 163 | two consecutive newlines ('\n'). *) 164 | end 165 | type log = Log.run_info -> Log.event -> unit 166 | (** The type for logs. *) 167 | 168 | val term_log : Format.formatter -> log 169 | (** [term_log fmt] logs events on [fmt], uses 170 | {{:http://www.ecma-international.org/publications/standards/Ecma-048.htm} 171 | ANSI escape sequences} for interactive feedback. *) 172 | 173 | val batch_log : Format.formatter -> log 174 | (** Same as {!term_log} but doesn't use ANSI escape sequences. *) 175 | 176 | type run_conf = 177 | { selectors : string list; (** Test name prefixes (see below). *) 178 | sort : (string -> string -> int) option; (** Test sorter. *) 179 | no_exec : bool; (** Don't execute tests only log their names. *) 180 | fail_stop : bool; (** Stop the run on the first test failure. *) 181 | verbose : int; (** Test monitoring verboseness. *) 182 | gen_seed : int option; (** Random seed for random case generation. *) 183 | gen_size : int; (** Hinted generated case size. *) 184 | gen_kill : int option; 185 | (** Number of generated cases before killing 4 * success if 186 | unspecified. *) 187 | gen_success : int; (** Number of successful cases before succeeding. *) 188 | gen_falsifiers : int; (** Number of failing cases reported. *) } 189 | (** The type for run configuration. 190 | 191 | [selectors] is a list of prefixes, only tests whose names 192 | match a prefix in [selectors] are performed. If [selector] 193 | is the empty list all tests are selected. 194 | 195 | Properties starting with [gen] pertain to automatic test 196 | case generation. TODO link to how it works and meaning of args.*) 197 | 198 | val run_conf : run_conf 199 | (** [run_conf] is the default run configuration. *) 200 | 201 | val run : log -> run_conf -> test list -> [ `Ok | `Fail ] 202 | (** [run logger conf tl] runs the test list [tl] with configuration 203 | [conf] and feedbacks the result with [log]. [`Ok] is returned 204 | iff all tests succeed. *) 205 | 206 | val runf : ?log:log -> run_conf -> (run -> 'a) -> [ `Ok | `Fail ] 207 | (** [runf conf f] runs the test function [f] with the configuration [conf] 208 | and feedbacks the result on stdout. *) 209 | 210 | (** {3:commandline Command line options} *) 211 | 212 | val log_args : (Format.formatter -> log) ref -> 213 | (Arg.key * Arg.spec * Arg.doc) list 214 | (** [log_args lr] returns a list of command line argument specifications 215 | to use with the [Arg] module to define the log in [lr]. *) 216 | 217 | val run_conf_args : run_conf ref -> (Arg.key * Arg.spec * Arg.doc) list 218 | (** [run_conf_args cr] returns a list of command line argument specifications 219 | to use with the [Arg] module to define the run configuration in [cr]. *) 220 | 221 | end 222 | 223 | 224 | (** Checks (assertions) 225 | 226 | Checks perform assertions with precise error reports. 227 | 228 | Most combinators have two optional arguments. 229 | [id] an optional string that may help to identify a check. 230 | [pr] an optional value printer. Used to print the arguments 231 | given to checks, use {!Make} to apply the argument for 232 | a given type. 233 | *) 234 | module C : sig 235 | 236 | type check = Test.run -> Test.run 237 | (** The type for checks. A check 238 | 239 | A check is just a function that threads the 240 | tester. check combinators generate checks. Just a way to 241 | pass implicit arguments by. *) 242 | 243 | val neg : ('a -> bool ) -> ('a -> bool) 244 | (** [neg p x] is [true] iff [p x] is [false]. *) 245 | 246 | val success : check 247 | (** [success] is a check that always succeeds. *) 248 | 249 | val holds : ?id:string -> ?pr:'a printer -> ('a -> bool) -> 'a -> check 250 | (** [holds p v] succeeds [iff] [p v] is [true]. *) 251 | 252 | val for_all : ?id:string -> ?pr:'a printer -> ?classify:('a -> string) -> 253 | ?cond:('a -> bool) -> 'a gen -> ('a -> Test.run -> 'b) -> check 254 | (** [for_all classify cond g c] will repeateadly generate values [v] 255 | from [g], if [cond v] is [true] will check [c v] (number of 256 | tested values depends on tester and [cond] defaults to [fun _ -> 257 | true]) If given [classify] sorts value into equivalence classes 258 | to compute a distribution of the generated values. *) 259 | 260 | val no_raise : ?id:string -> ?pr:'a printer -> ('a -> 'b) -> 'a -> check 261 | (** [no_raise f v] succeeds iff [f v] raises no exception. *) 262 | 263 | val raises : ?id:string -> ?pr:'a printer -> ?prr:'b printer -> 264 | ?exn:(exn -> bool) -> 265 | ('a -> 'b) -> 'a -> check 266 | (** [raises ~exn f v] succeeds iff [f v] raises an exception [e] such 267 | that [exn e] is [true] ([exn] defaults to [fun _ -> true]). *) 268 | 269 | val raises_failure : ?id:string -> ?pr:'a printer -> ?prr:'b printer -> 270 | ('a -> 'b) -> 'a -> check 271 | (** [raises_failure f v] succeeds iff [f v] raises [Failure]. *) 272 | 273 | val raises_invalid_arg : ?id:string -> ?pr:'a printer -> ?prr:'b printer -> 274 | ('a -> 'b) -> 'a -> check 275 | (** [raises_invalid_arg f v] succeeds iff [f v] raises 276 | [Invalid_argument]. *) 277 | 278 | val catch : check -> ('a -> 'b) -> 'a -> check 279 | (** [catch c f v] executes [c] if it fails the failure 280 | is catched and [f v] is executed. The [catch] check 281 | always succeeds. *) 282 | 283 | val log : 'a printer -> 'a -> check 284 | (** Not a check, [log pr v] logs the value [v] in the log using 285 | printer [pr]. *) 286 | 287 | (** Comparison predicates. 288 | 289 | These are the most important checks. This module 290 | must be opened in your scope. 291 | 292 | Being polymorphic they cannot print their arguments. Use 293 | them infinx with an appropriate [pr] parameter or better 294 | use the functor to specialize the predicates on a type. 295 | 296 | All these combinators except the physical ones use 297 | [Stdlib.compare]. Use the functor if you need another 298 | comparison function. *) 299 | module Order : sig 300 | 301 | type 'a cmp = 302 | ?cmp:('a -> 'a -> int) -> ?id:string -> ?pr:'a printer -> 'a -> 'a -> 303 | check 304 | (** The type for comparisons. Just a shortcut. *) 305 | 306 | val (=) : 'a cmp 307 | val (<>) :'a cmp 308 | val (<) : 'a cmp 309 | val (<=) : 'a cmp 310 | val (>) : 'a cmp 311 | val (>=) : 'a cmp 312 | val (==) : ?id:string -> ?pr:'a printer -> 'a -> 'a -> check 313 | val (!=) : ?id:string -> ?pr:'a printer -> 'a -> 'a -> check 314 | end 315 | 316 | 317 | (** {1 Combinator specialization} 318 | 319 | Given a comparison function [compare] a printer [print] and a 320 | type [t] the functor {Checkm.C.Make} automatically applies the 321 | [pr] parameter and generates suitable {!Order} predicates. 322 | 323 | Basic types are already specialized in the module C.Special 324 | open this module to use them. 325 | 326 | TODO Testable.t should maybe be type 'a Testable.t *) 327 | 328 | 329 | module type Testable = sig 330 | type t 331 | val pp : Format.formatter -> t -> unit 332 | val compare : t -> t -> int 333 | end 334 | 335 | module type S = sig 336 | type t 337 | 338 | 339 | val holds : ?id:string -> (t -> bool) -> t -> check 340 | 341 | val for_all : ?id:string -> ?classify:(t -> string) -> ?cond:(t -> bool) -> 342 | t gen -> (t -> Test.run -> 'b) -> check 343 | 344 | val no_raise : ?id:string -> (t -> 'b) -> t -> check 345 | 346 | val raises : ?id:string -> ?prr:'b printer -> 347 | ?exn:(exn -> bool) -> (t -> 'b) -> t -> check 348 | 349 | val raises_failure : ?id:string -> ?prr:'b printer -> 350 | (t -> 'b) -> t -> check 351 | 352 | val raises_invalid_arg : ?id:string -> ?prr:'b printer -> 353 | (t -> 'b) -> t -> check 354 | 355 | val log : t -> check 356 | 357 | module Order : sig 358 | val (=) : ?id:string -> t -> t -> check 359 | val (<>) : ?id:string -> t -> t -> check 360 | val (<) : ?id:string -> t -> t -> check 361 | val (<=) : ?id:string -> t -> t -> check 362 | val (>) : ?id:string -> t -> t -> check 363 | val (>=) : ?id:string -> t -> t -> check 364 | val (==) : ?id:string -> t -> t -> check 365 | val (!=) : ?id:string -> t -> t -> check 366 | end 367 | end 368 | 369 | module Make (T : Testable) : S with type t = T.t 370 | 371 | module Special : sig 372 | module Cb : S with type t = bool 373 | module Cc : S with type t = char 374 | module Ci : S with type t = int 375 | module Cf : S with type t = float 376 | module Cs : S with type t = string 377 | end 378 | end 379 | 380 | (** Test case generators. 381 | 382 | {b Note.} Not all generators are random. 383 | *) 384 | module Gen : sig 385 | 386 | val pr : 'a gen -> 'a printer 387 | val gen : 'a gen -> (int -> Random.State.t -> 'a) 388 | 389 | (** {1:base Base type random generators} *) 390 | 391 | val unit : unit gen 392 | (** [unit] generates always [()]. *) 393 | 394 | val const : 'a -> 'a printer -> 'a gen 395 | (** [const v pr] generates always [v] and prints it with [pr]. *) 396 | 397 | val bool : bool gen 398 | (** [bool] generates [bool] values. *) 399 | 400 | val uint : ?max:int -> unit -> int gen 401 | (** [uint max ()] is a generator for [int] values in \[[0;max]\] 402 | ([max] defaults to [max_int]). *) 403 | 404 | (** {1:higher Higher order generators} *) 405 | 406 | val option : 'a gen -> 'a option gen 407 | (** [option g] randomly generates option cases. The [Some] case values 408 | are generated by [g]. *) 409 | 410 | 411 | val t2 : 'a gen -> 'b gen -> ('a * 'b) gen 412 | (** [t2 g0 g1] generates a couple with [g0] and [g1]. *) 413 | 414 | val t3 : 'a gen -> 'b gen -> 'c gen -> ('a * 'b * 'c) gen 415 | (** [t3 g0 g1 g2] generates a triplet with [g0], [g1] and [g2]. *) 416 | 417 | val t4 : 'a gen -> 'b gen -> 'c gen -> 'd gen -> ('a * 'b * 'c * 'd) gen 418 | (** [t4 g0 g1 g2 g3] generates a quadruplet with [g0], [g1], [g2] and [g3]. *) 419 | 420 | val t5 : 'a gen -> 'b gen -> 'c gen -> 'd gen -> 'e gen -> 421 | ('a * 'b * 'c * 'd * 'e) gen 422 | (** [t5 g0 g1 g2 g3 g4] generates a quintuplet with [g0], [g1], [g2], [g3] 423 | and [g4]. *) 424 | 425 | val t6 : 'a gen -> 'b gen -> 'c gen -> 'd gen -> 'e gen -> 'f gen -> 426 | ('a * 'b * 'c * 'd * 'e * 'f) gen 427 | (** [t6 g0 g1 g2 g3 g4 g5] generates a sextuplet with [g0], [g1], [g2], [g3], 428 | [g4] and [g5] *) 429 | 430 | (* 431 | 432 | 433 | val int : ?amax:int -> int gen 434 | (** [int amax] is a generator for [int] values in \[[-amax;amax]\] 435 | ([amax] defaults to [max_int]). Note that [min_int] is never generated. *) 436 | 437 | val ufloat : ?max:float -> float gen 438 | (** [ufloat max] is a generator for [float] values in \[[0;max]\] 439 | ([max] defaults to [max_float]). *) 440 | 441 | val float : ?amax:float -> float gen 442 | (** [float amax] is a generator for [float] values in \[[-amax;amax]\] 443 | ([amax] defaults to [max_float]) *) 444 | 445 | val char : char gen 446 | (** [char] is a generator for latin1 [char]s. *) 447 | 448 | (** {1:higher Higher order generators} *) 449 | 450 | val string : ?len:int gen -> ?c:char gen -> string gen 451 | (** [string len] is a generator for latin1 [string]s whose 452 | length is generated by [len] (defaults to [uint ~max:1000]) 453 | and characters by [c] (defaults to [char]). *) 454 | 455 | val option : 'a gen -> 'a option gen 456 | (** [option g] is a generator for option values using [g] if there's some. *) 457 | 458 | val pair : 'a gen -> 'b gen -> ('a * 'b) gen 459 | (** [pair g g'] is generetor for pairs using [g] and [g']. *) 460 | 461 | val list : ?len:int gen -> 'a gen -> 'a list gen 462 | (** [list len g] is a generator for [list] values whose 463 | length is generated by [len] (defaults to [uint ~max:1000]) 464 | and elements by [g].*) 465 | 466 | val map : ('a -> 'b) -> 'a gen -> 'b gen 467 | (** [map f g] is the generator for values in ['b] by 468 | mapping the result of [g] with [f]. *) 469 | 470 | val filter : ('a -> bool) -> 'a gen -> 'a gen 471 | (** [filter p g] is the generator with values [v] from 472 | [g] such that [p v] is true. *) 473 | 474 | val choose : 'a gen list -> 'a gen 475 | (** [choose gl] is the generator using the generators in [gl] 476 | equiprobably. *) 477 | 478 | *) 479 | 480 | end 481 | 482 | (** {1:basics Basics} 483 | 484 | Three steps. 485 | 486 | 1. Introduce the test module. 487 | 488 | A test is just a function taking a tester (ignore it for now). 489 | If the function returns a value the tests succeeds, if it 490 | raises any exception it fails. 491 | 492 | * defining test 493 | * running & selecting test. 494 | * global list of tests. 495 | 496 | 2. Introduce checks. 497 | 3. Introduce checks with case generation. 498 | 499 | 500 | TODO polish and distribute separately. 501 | TODO remove dependency on Str. 502 | TODO add a module for generators. 503 | 504 | Rationale. 505 | * avoid names as much as possible. 506 | * on failure, backtrace (for emacs). 507 | * on failure, print as much as possible, arguments, result 508 | expected result. Toplevel feel. 509 | 510 | 511 | Test unit {Test.unit} is a named function taking a tester. 512 | Unit of failure. 513 | 514 | 515 | TODO. A {e check} is a property you want to verify. Conjuctions of 516 | checks are combined into named {e units}. A unit is a check itself 517 | so it can be combined with other checks. A check either succeeds 518 | or fails. If it succeeds the next check in the conjuction is 519 | executed. If it fails it aborts immediatly the rest of the checks 520 | in the unit. A unit itself always succeeds regardless of what 521 | happened to its checks this allows to run sequences of 522 | units. There are however different ways to abort a unit 523 | 524 | {e outcome} of a unit depends on its checks. 525 | TIPS heavy weight predicate vs fine grained seqs with compare. 526 | 527 | *) 528 | -------------------------------------------------------------------------------- /test/color_schemes.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2013 The gg programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | open Gg 7 | open Gg_kit 8 | open Vg 9 | 10 | (* TODO code a proper Vz color scheme explorator with sliders etc. *) 11 | 12 | let log fmt = Format.printf (fmt ^^ "@.") 13 | 14 | (* Color schemes to display. *) 15 | 16 | let schemes = 17 | let h = Float.rad_of_deg in 18 | [ `C (true, Color_scheme.sequential_wijffelaars ~w:0. ~h:(h 255.) (), 9.); 19 | `D (true, 20 | Color_scheme.sequential_wijffelaars' ~w:0. ~h:(h 255.) ~size:9 (), 9); 21 | `D (true, 22 | Color_scheme.sequential_wijffelaars' ~w:0.15 ~h:(h 255.) ~size:9 (), 9); 23 | `D (true, 24 | Color_scheme.sequential_wijffelaars' ~w:0.9 ~h:(h 255.) ~size:9 (), 9); 25 | `D (true, 26 | Color_scheme.sequential_wijffelaars' ~w:0.5 ~h:(h 10.) ~size:9 (), 9); 27 | `D (true, 28 | Color_scheme.sequential_wijffelaars' ~h:(h 10.) ~size:9 (), 9); 29 | `D (true, 30 | Color_scheme.sequential_wijffelaars' 31 | ~s:0.5 ~b:1. ~h:(h 255.) ~size:9 (), 9); 32 | `Blank; 33 | `C (true, Color_scheme.sequential_turbo (), 9.); 34 | `C (true, Color_scheme.sequential_magma (), 9.); 35 | `C (true, Color_scheme.sequential_inferno (), 9.); 36 | `C (true, Color_scheme.sequential_plasma (), 9.); 37 | `C (true, Color_scheme.sequential_viridis (), 9.); 38 | `Blank; 39 | `C (true, 40 | Color_scheme.diverging_wijffelaars ~w:0.15 ~h0:(h 255.) ~h1:(h 10.) (), 41 | 9.); 42 | `D (true, 43 | Color_scheme.diverging_wijffelaars' 44 | ~w:0.15 ~h0:(h 255.) ~h1:(h 10.) ~size:9 (), 9); 45 | `D (true, 46 | Color_scheme.diverging_wijffelaars' 47 | ~m:0.6 ~w:0.15 ~h0:(h 255.) ~h1:(h 10.) ~size:9 (), 9); 48 | `C (true, 49 | Color_scheme.diverging_wijffelaars 50 | ~m:0.6 ~w:0.15 ~h0:(h 255.) ~h1:(h 10.) (), 9.); 51 | `D (true, 52 | Color_scheme.diverging_wijffelaars' 53 | ~w:0.15 ~h0:(h 255.) ~h1:(h 10.) ~size:8 (), 8); 54 | `D (true, 55 | Color_scheme.diverging_wijffelaars' 56 | ~w:0. ~h0:(h 255.) ~h1:(h 10.) ~size:9 (), 9); 57 | `D (true, 58 | Color_scheme.diverging_wijffelaars' 59 | ~w:1. ~s:0.7 ~h0:(h 120.) ~h1:(h 10.) ~size:9 (), 9); 60 | `D (true, 61 | Color_scheme.diverging_wijffelaars' 62 | ~h0:(h 255.) ~h1:(h 10.) ~s:0.3 ~c:0.9 ~b:0.5 ~size:6 (), 6); 63 | `Blank; 64 | `C (true, Color_scheme.cyclic_sinebow (), 9.); 65 | `Blank; 66 | `D (false, Color_scheme.qualitative `Brewer_accent_8 (), 8); 67 | `D (false, Color_scheme.qualitative `Brewer_dark2_8 (), 8); 68 | `D (false, Color_scheme.qualitative `Brewer_paired_12 (), 12); 69 | `D (false, Color_scheme.qualitative `Brewer_pastel1_9 (), 9); 70 | `D (false, Color_scheme.qualitative `Brewer_pastel2_8 (), 8); 71 | `D (false, Color_scheme.qualitative `Brewer_set1_9 (), 9); 72 | `D (false, Color_scheme.qualitative `Brewer_set2_8 (), 8); 73 | `D (false, Color_scheme.qualitative `Brewer_set3_12 (), 12); 74 | `D (false, Color_scheme.qualitative `Tableau_10 (), 10); 75 | `D (false, Color_scheme.qualitative `Wijffelaars_17 (), 17); 76 | `D (false, Color_scheme.qualitative_wijffelaars ~size:8 (), 8); 77 | `D (false, Color_scheme.qualitative_wijffelaars ~c:0.8 ~size:8 (), 8); ] 78 | 79 | (* Continuous and discrete color schemes as images *) 80 | 81 | let range ?(min = 0.) ?(max = 1.) dt f acc = 82 | let n = truncate (((max -. min) /. dt) +. 1.) in 83 | let maxi = n - 1 in 84 | let rec loop acc i = 85 | if i < maxi then loop (f acc (min +. (float i) *. dt)) (i + 1) else 86 | f acc max 87 | in 88 | loop (f acc min) 1 89 | 90 | let colors_continuous ?(rev = false) cs len = 91 | (* scheme sampled every 0.05 unit of len *) 92 | let dt = 1. /. (floor ((len /. 0.05) +. 1.)) in 93 | let add_sample acc t = ((if rev then 1. -. t else t), cs t) :: acc in 94 | let stops = 95 | let stops = range dt add_sample [] in 96 | if rev then stops else List.rev stops 97 | in 98 | let bounds = P.empty |> P.rect (Box2.v P2.o (Size2.v 1. len)) in 99 | I.axial stops P2.o (P2.v 0. len) |> I.cut bounds 100 | 101 | let colors_discrete ?(rev = false) cs n = 102 | let cs = Array.init n cs in 103 | let sq = 104 | let sq = Box2.v P2.o (Size2.v 1. 1.01 (* overlap *)) in 105 | P.empty |> P.rect sq 106 | in 107 | let bounds = 108 | let n = Array.length cs in 109 | P.empty |> P.rect (Box2.v P2.o (Size2.v 1. (float n))) 110 | in 111 | let mv = P2.v 0. 1.0 in 112 | let add acc c = acc |> I.move mv |> I.blend (I.const c |> I.cut sq) in 113 | let colors = 114 | if rev then Array.fold_left add I.void cs else 115 | Array.fold_right (fun c acc -> add acc c) cs I.void 116 | in 117 | colors |> I.cut bounds (* cut topmost overlap *) 118 | 119 | let size = Size2.v 300. 100. (* mm *) 120 | let view = Box2.v P2.o (Size2.v 60. 20.) 121 | let image = 122 | let add scheme acc = 123 | let i = match scheme with 124 | | `D (rev, cs, n) -> colors_discrete ~rev cs n 125 | | `C (rev, cs, n) -> colors_continuous ~rev cs n 126 | | `Blank -> I.void 127 | in 128 | acc |> I.move (P2.v 1.5 0.0) |> I.blend i 129 | in 130 | List.fold_right add schemes I.void 131 | |> I.scale (V2.v 1. (-1.)) |> I.move (V2.v 0. 20.) 132 | 133 | (* Browser bureaucracy. *) 134 | 135 | open Brr 136 | open Brr_canvas 137 | 138 | let main () = 139 | let body = (Document.body G.document) in 140 | let c = Canvas.create [] in 141 | let () = El.append_children body [Canvas.to_el c] in 142 | let r = 143 | let t = Vgr_htmlc.target (* ~resize:true *) (Obj.magic c) in 144 | Vg.Vgr.create t `Other 145 | in 146 | assert(Vgr.render r (`Image (size, view, image)) = `Ok); 147 | () 148 | 149 | let () = main () 150 | -------------------------------------------------------------------------------- /test/lcmsgen.c: -------------------------------------------------------------------------------- 1 | /*--------------------------------------------------------------------------- 2 | Copyright (c) 2013 Török Edwin 3 | 4 | Permission to use, copy, modify, and/or distribute this software for any 5 | purpose with or without fee is hereby granted, provided that the above 6 | copyright notice and this permission notice appear in all copies. 7 | 8 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | ---------------------------------------------------------------------------*/ 16 | 17 | /* Usage: 18 | * $ gcc lcmsgen.c `pkg-config lcms2 --libs --cflags` -O2 -o lcmsgen 19 | * $ ./lcmsgen >rgbtest.csv 20 | */ 21 | #include 22 | #include 23 | #include 24 | #include 25 | 26 | static double frand(void) 27 | { 28 | return (double)rand() / (double)RAND_MAX; 29 | } 30 | 31 | static cmsHTRANSFORM xform_srgb_to_lrgb; 32 | static cmsHTRANSFORM xform_srgb_to_lab; 33 | static cmsHTRANSFORM xform_srgb_to_lgray; 34 | 35 | static void generate_testcase(double r, double g, double b) 36 | { 37 | double SRGB[3] = {r,g,b}; 38 | double LRGB[3]; 39 | cmsCIELab Lab; 40 | double gray; 41 | cmsDoTransform(xform_srgb_to_lrgb, SRGB, LRGB, 1); 42 | cmsDoTransform(xform_srgb_to_lab, SRGB, &Lab, 1); 43 | cmsDoTransform(xform_srgb_to_lgray, SRGB, &gray, 1); 44 | /* Use 6 digits precision. do not use more because you'd start seeing 45 | * small errors, probably because LCMS is using single precision float 46 | * internally. 47 | * This means 4 fractional digits for Lab, since it already has ~2 before. 48 | * */ 49 | printf("%.6f,%.6f,%.6f,%.6f,%.6f,%.6f,%.4f,%.4f,%.4f,%6f\n", 50 | SRGB[0],SRGB[1],SRGB[2], 51 | LRGB[0],LRGB[1],LRGB[2], 52 | Lab.L, Lab.a, Lab.b, gray); 53 | } 54 | 55 | static void errlog(cmsContext id, cmsUInt32Number code, const char *text) 56 | { 57 | printf("Error (%x): %s\n", code, text); 58 | } 59 | 60 | static void init(void) 61 | { 62 | cmsCIEXYZ D65_XYZ = {0.95047, 1.0, 1.08883 }; 63 | cmsCIExyY D65; 64 | cmsXYZ2xyY(&D65, &D65_XYZ); 65 | 66 | cmsToneCurve *linear = cmsBuildGamma(NULL, 1.0); 67 | cmsToneCurve *linrgb[3] = {linear,linear,linear}; 68 | cmsCIExyYTRIPLE primaries = { 69 | {0.64, 0.33, 1.0}, 70 | {0.30, 0.60, 1.0}, 71 | {0.15, 0.06, 1.0} 72 | }; 73 | 74 | cmsFloat64Number P[5] = { 2.4, 1. / 1.055, 0.055 / 1.055, 1. / 12.92, 0.04045 }; 75 | cmsToneCurve *srgb = cmsBuildParametricToneCurve(NULL, 4, P); 76 | cmsToneCurve *srgbcurve[3] = {srgb,srgb,srgb}; 77 | cmsHPROFILE hsRGB = cmsCreateRGBProfile(&D65, &primaries, srgbcurve); 78 | cmsHPROFILE hLab = cmsCreateLab4Profile(NULL); 79 | cmsHPROFILE hlRGB = cmsCreateRGBProfile(&D65, &primaries, linrgb); 80 | cmsHPROFILE hlGray = cmsCreateGrayProfile(cmsD50_xyY(), linear); 81 | 82 | cmsSetHeaderFlags(hlGray, cmsEmbeddedProfileTrue); 83 | cmsSaveProfileToFile(hlGray,"lgray.icc"); 84 | cmsSetHeaderFlags(hlRGB, cmsEmbeddedProfileTrue); 85 | cmsSaveProfileToFile(hlRGB,"lrgb.icc"); 86 | 87 | xform_srgb_to_lrgb = cmsCreateTransform(hsRGB, TYPE_RGB_DBL, 88 | hlRGB, TYPE_RGB_DBL, 89 | INTENT_RELATIVE_COLORIMETRIC, 90 | cmsFLAGS_NOOPTIMIZE /* preserve precision */ 91 | ); 92 | xform_srgb_to_lab = cmsCreateTransform(hsRGB, TYPE_RGB_DBL, hLab, 93 | TYPE_Lab_DBL, INTENT_RELATIVE_COLORIMETRIC, 94 | cmsFLAGS_NOOPTIMIZE); 95 | xform_srgb_to_lgray = cmsCreateTransform(hsRGB, TYPE_RGB_DBL, hlGray, 96 | TYPE_GRAY_DBL, INTENT_RELATIVE_COLORIMETRIC, 97 | cmsFLAGS_NOOPTIMIZE); 98 | cmsCloseProfile(hsRGB); 99 | cmsCloseProfile(hlRGB); 100 | cmsCloseProfile(hLab); 101 | cmsCloseProfile(hlGray); 102 | cmsFreeToneCurve(linear); 103 | cmsFreeToneCurve(srgb); 104 | cmsSetLogErrorHandler(errlog); 105 | /* sRGB, RGB, Lab, Gray */ 106 | printf("R',G',B',R,G,B,L,a,b,Gray\n"); 107 | } 108 | 109 | static void done(void) 110 | { 111 | cmsDeleteTransform(xform_srgb_to_lrgb); 112 | cmsDeleteTransform(xform_srgb_to_lab); 113 | cmsDeleteTransform(xform_srgb_to_lgray); 114 | } 115 | 116 | int main(void) 117 | { 118 | unsigned i; 119 | init(); 120 | /* Generate testcases for in-gamut colors */ 121 | 122 | /* generate testcases for monochromatic values */ 123 | for (i=0;i<256;i++) { 124 | double v = ((double)i) / 255.0; 125 | generate_testcase(v,v,v); 126 | } 127 | /* generate some color testcases */ 128 | for (i=0;i<256;i++) { 129 | double r = ((double)i) / 255.0; 130 | double g = fmod((double)i + 128.5, 255.0) / 255.0; 131 | double b = fmod(255.25 - (double)i, 255.0) / 255.0; 132 | generate_testcase(r,g,b); 133 | } 134 | srand(1); 135 | /* generate some random colors */ 136 | for (i=0;i<256;i++) { 137 | generate_testcase(frand(),frand(),frand()); 138 | } 139 | done(); 140 | } 141 | -------------------------------------------------------------------------------- /test/orient_p2.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2022 The gg programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | open Gg 7 | open Brr_canvas 8 | open Brr 9 | 10 | (* This set of coordinates was found via 11 | https://observablehq.com/@mourner/non-robust-arithmetic-as-art *) 12 | 13 | let p = P2.v 16.5 16.5 14 | let q = P2.v 18. 18. 15 | let r0 = P2.v 0.5 0.5 16 | let window = 2. ** (-42.) 17 | 18 | let render_predicate ~w:iw ~h:ih orient = 19 | let c = Canvas.create ~w:iw ~h:ih [] in 20 | let w = float iw and h = float ih in 21 | let ctx = C2d.get_context c in 22 | C2d.clear_rect ctx ~x:0. ~y:0. ~w ~h; 23 | let data = C2d.get_image_data ctx ~x:0 ~y:0 ~w:iw ~h:ih in 24 | let pixels = Tarray.to_bigarray1 (C2d.Image_data.data data) in 25 | for y = 0 to ih - 1 do 26 | for x = 0 to iw - 1 do 27 | let rx = P2.x r0 +. (float x *. (window /. w)) in 28 | let ry = P2.y r0 +. (float y *. (window /. h)) in 29 | let r, g, b = 30 | (* if x = y then 0x00, 0x00, 0x00 else *) 31 | match orient p q (P2.v rx ry) with 32 | | o when o < 0. -> 0x38, 0x6c, 0xb0 33 | | o when o = 0. -> 0xfd, 0xc0, 0x86 34 | | o (* when o > 0. *) -> 0xf0, 0x02, 0x7f 35 | in 36 | let off = 4 * (y * iw + x) in 37 | Bigarray.Array1.set pixels (off ) r; 38 | Bigarray.Array1.set pixels (off + 1) g; 39 | Bigarray.Array1.set pixels (off + 2) b; 40 | Bigarray.Array1.set pixels (off + 3) 0xFF; 41 | done; 42 | done; 43 | C2d.put_image_data ctx data ~x:0 ~y:0; 44 | Canvas.to_el c 45 | 46 | let main () = 47 | let h1 = El.h1 [El.txt' "Orientation predicates"] in 48 | let fast = render_predicate ~w:350 ~h:350 P2.orient_fast in 49 | let robust = render_predicate ~w:350 ~h:350 P2.orient in 50 | let html = [h1; fast; El.txt' "   "; robust] in 51 | El.set_children (Document.body G.document) html 52 | 53 | let () = main () 54 | -------------------------------------------------------------------------------- /test/pgon2_bool_steps.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2022 The gg programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | open Gg 7 | open Gg_kit 8 | open Vg 9 | open Brr_canvas 10 | open Brr 11 | 12 | (* The tested polygons *) 13 | 14 | let test = List.hd Pgon2_test_cases.list 15 | let step_op = Pgon2.Inter 16 | 17 | let qual = Color_scheme.qualitative ~a:0.5 `Brewer_accent_8 () 18 | let green = qual 0 19 | let purple = qual 1 20 | let yellowish = qual 6 (* segment above *) 21 | let pink = qual 5 (* segment below *) 22 | 23 | let v_stack ~gutter imgs = (* Start at P2.o and left-aligned on oy *) 24 | let rec loop gutter maxw pos acc = function 25 | | [] -> Box2.v P2.o (Size2.v maxw (P2.y pos)), acc 26 | | (b, i) :: is -> 27 | let tr = V2.(pos - Box2.o b) in 28 | let acc = I.blend (I.move tr i) acc in 29 | let dy = Box2.h b +. if is = [] then 0. else gutter in 30 | let pos = V2.v (P2.x pos) (P2.y pos +. dy) in 31 | let maxw = Float.max maxw (Box2.w b) in 32 | loop gutter maxw pos acc is 33 | in 34 | loop gutter Float.min_float P2.o I.void imgs 35 | 36 | let h_stack ~gutter imgs = (* Start at P2.o and bottom-aligned on ox *) 37 | let rec loop gutter maxh pos acc = function 38 | | [] -> Box2.v P2.o (Size2.v (P2.x pos) maxh), acc 39 | | (b, i) :: is -> 40 | let tr = V2.(pos - Box2.o b) in 41 | let acc = I.blend (I.move tr i) acc in 42 | let dx = Box2.w b +. if is = [] then 0. else gutter in 43 | let pos = V2.v (P2.x pos +. dx) (P2.y pos) in 44 | let maxh = Float.max maxh (Box2.h b) in 45 | loop gutter maxh pos acc is 46 | in 47 | loop gutter Float.min_float P2.o I.void imgs 48 | 49 | (* Geometry images *) 50 | 51 | let cut_pt ~w pt color = 52 | let p = P.empty |> P.circle pt (0.5 *. w) in 53 | let outline = `O { P.o with width = 0.15 *. 0.5 *. w } in 54 | let full = Color.with_a color 1.0 in 55 | I.cut p (I.const color) |> I.blend (I.cut ~area:outline p (I.const full)) 56 | 57 | let ring_path ?(acc = P.empty) c = 58 | let add pt p = if p == acc then P.sub pt p else P.line pt p in 59 | P.close (Ring2.fold_pts add c acc) 60 | 61 | let pgon_path p = 62 | let add c path = ring_path c ~acc:path in 63 | Pgon2.fold_rings add p P.empty 64 | 65 | let cut_pgon ?(o = I.const Color.black) ?(area = `Aeo) ~w:width p i = 66 | let outline = `O { P.o with width } in 67 | let p = pgon_path p in 68 | I.cut ~area p i |> I.blend (I.cut ~area:outline p o) 69 | 70 | let cut_box ~w:width b color = 71 | let outline = `O { P.o with width } in 72 | I.cut ~area:outline (P.rect b P.empty) (I.const color) 73 | 74 | let cut_seg ~w:width p0 p1 color = 75 | let area = `O { P.o with width } in 76 | I.cut ~area (P.empty |> P.sub p0 |> P.line p1) (I.const color) 77 | 78 | (* Algorithm images *) 79 | 80 | let cut_sweep_line ~w:width ~x ~box color = 81 | let dashes = Some (0., [width; width]) in 82 | let area = `O { P.o with width; dashes } in 83 | let l0 = V2.v x (Box2.miny box) and l1 = V2.v x (Box2.maxy box) in 84 | I.cut ~area (P.empty |> P.sub l0 |> P.line l1) (I.const color) 85 | 86 | let cut_sweep_result ~w evs = 87 | let add acc (e : Pgon2.Event.t) = 88 | if not e.is_left then acc else 89 | let color (e : Pgon2.Event.t) = if e.in_result then green else (qual 2) in 90 | let p0 = e.pt and p1 = e.other.pt in 91 | acc 92 | |> I.blend (cut_seg ~w p0 p1 Color.black) 93 | |> I.blend (cut_pt ~w:(5. *. w) p0 (color e)) 94 | |> I.blend (cut_pt ~w:(5. *. w) p1 (color e.other)) 95 | in 96 | List.fold_left add I.void evs 97 | 98 | let cut_step_event ~w ~box (ev : Pgon2.Event.t) = 99 | let p0 = ev.pt and p1 = ev.other.pt in 100 | let sweep_line = cut_sweep_line ~w:(w *. 0.5) ~x:(P2.x p0) ~box Color.black in 101 | let seg_w = if ev.in_result || ev.other.in_result then 8. *. w else w in 102 | let linec = if ev.polygon = Pgon2.Subject then green else (qual 1) in 103 | sweep_line 104 | |> I.blend (cut_seg ~w:seg_w p0 p1 linec) 105 | |> I.blend (cut_pt ~w:(8. *. w) p0 linec) 106 | |> I.blend (cut_pt ~w:(8. *. w) p1 linec) 107 | 108 | let cut_step ~w ~box below ev above ss = 109 | let cut_neighbor ~is_above = function 110 | | None -> I.void 111 | | Some (ev : Pgon2.Event.t) -> 112 | let c = if is_above then yellowish else pink in 113 | cut_seg ~w:(4. *. w) ev.pt ev.other.pt c 114 | in 115 | let status_others = 116 | let ev = Some ev and eq = Option.equal ( == ) in 117 | let add acc (e : Pgon2.Event.t) = 118 | let se = Some e in 119 | if eq se below || eq se ev || eq se above then acc else 120 | I.blend (cut_seg ~w:(4. *. w) e.pt e.other.pt (Color.gray ~a:0.2 0.)) acc 121 | in 122 | List.fold_left add I.void ss 123 | in 124 | status_others 125 | |> I.blend (cut_step_event ~w ~box ev) 126 | |> I.blend (cut_neighbor ~is_above:false below) 127 | |> I.blend (cut_neighbor ~is_above:true above) 128 | 129 | let dump_ring ppf c = 130 | let pp_v2 ppf pt = Format.fprintf ppf "%.17f, %.17f" (V2.x pt) (V2.y pt) in 131 | let pts = List.rev (Ring2.fold_pts List.cons c []) in 132 | let pp_sep ppf () = Format.fprintf ppf ";@," in 133 | Format.fprintf ppf "@[[%a]@]" (Format.pp_print_list ~pp_sep pp_v2) pts 134 | 135 | let dump_pgon ppf p = 136 | let pp_sep ppf () = Format.fprintf ppf ";@," in 137 | let cs = List.rev (Pgon2.fold_rings List.cons p []) in 138 | Format.fprintf ppf "@[[%a]@]" 139 | (Format.pp_print_list ~pp_sep dump_ring) cs 140 | 141 | let dump_result r = 142 | Format.(printf "@[Results:@, @[%a@]@]@." 143 | (pp_print_list Pgon2.Event.pp_dump) r) 144 | 145 | let retract r = 146 | let v = match r with Ok (v, _) -> v | Error ((v, _), _) -> v in 147 | let cpts c = Ring2.fold_pts (fun _ acc -> acc + 1) c 0 in 148 | let cs = Pgon2.fold_rings (fun c acc -> cpts c :: acc) v [] in 149 | Format.printf "@[Result ring counts: @[[%a]@]@,Result:@,%a@]@." 150 | Format.(pp_print_list ~pp_sep:pp_print_space pp_print_int) cs dump_pgon v; 151 | v 152 | 153 | let img p0 p1 step_op = 154 | let box, gutter = 155 | let box = Box2.union (Pgon2.box p0) (Pgon2.box p1) in 156 | let margin = V2.(0.1 * Box2.size box) in 157 | Box2.outset margin box, Size2.h margin 158 | in 159 | let w = 0.0025 *. Float.min (Box2.w box) (Box2.h box) in 160 | let h = h_stack ~gutter and v l = v_stack ~gutter (List.rev l) in 161 | let res = Pgon2.Sweep.debug_result step_op p0 p1 in 162 | dump_result res; 163 | let res = box, cut_sweep_result ~w res in 164 | let res' = 165 | box, cut_sweep_result ~w 166 | (Pgon2.Sweep.debug_result ~filtered:false step_op p0 p1) 167 | in 168 | let op = 169 | let cut_pgon p = cut_pgon ~w p (I.const (Color.gray 0.9 ~a:0.75)) in 170 | match step_op with 171 | | Pgon2.Union -> box, cut_pgon (retract (Pgon2.union p0 p1)) 172 | | Pgon2.Inter -> box, cut_pgon (retract (Pgon2.inter p0 p1)) 173 | | Pgon2.Diff -> box, cut_pgon (retract (Pgon2.diff p0 p1)) 174 | | Pgon2.Xor -> box, cut_pgon (retract (Pgon2.xor p0 p1)) 175 | in 176 | (* ^ are constant images, let's not recompute them every step *) 177 | fun step -> 178 | let step = match step with 179 | | None -> I.void | Some (b, ev, a, ss) -> cut_step ~w ~box b ev a ss 180 | in 181 | let cut_arg ~w p col = 182 | let o = I.const (Color.with_a col 1.0) and a = I.const col in 183 | cut_pgon ~w ~o p a 184 | in 185 | let p0 = cut_arg ~w p0 green in 186 | let p1 = cut_arg ~w p1 purple in 187 | let step = box, p0 |> I.blend p1 |> I.blend step in 188 | v [ h [step; res]; 189 | h [op; res']] 190 | 191 | let stepper op p0 p1 = 192 | let step = ref (Pgon2.Sweep.debug_stepper op p0 p1) in 193 | fun () -> match !step () with 194 | | None -> step := Pgon2.Sweep.debug_stepper op p0 p1; None 195 | | Some _ as v -> v 196 | 197 | let render r (view, img) = 198 | let aspect = Size2.aspect (Box2.size view) in 199 | let size = Size2.of_w 200. (* mm *) ~aspect in 200 | ignore (Vgr.render r (`Image (size, view, img))) 201 | 202 | let main () = 203 | let body = (Document.body G.document) in 204 | let c = Canvas.create [] in 205 | let () = El.append_children body [Canvas.to_el c] in 206 | let r = 207 | let t = Vgr_htmlc.target ~resize:true (Obj.magic c) in 208 | Vg.Vgr.create t `Other 209 | in 210 | let _, p0, p1, _, _ = test in 211 | let img = img p0 p1 step_op in 212 | let step = stepper step_op p0 p1 in 213 | let render_step () = render r (img (step ())) in 214 | let () = 215 | let on_click _ = render_step () in 216 | let on_keydown v = render_step () in 217 | ignore (Ev.listen Ev.click on_click (El.as_target body)); 218 | ignore (Ev.listen Ev.keydown on_keydown (El.as_target body)); 219 | in 220 | render r (img None); 221 | () 222 | 223 | let () = main () 224 | -------------------------------------------------------------------------------- /test/pgon2_bool_tests.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2022 The gg programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | open B0_std 7 | open Vg 8 | open Gg 9 | open Gg_kit 10 | 11 | (* Render *) 12 | 13 | let qual = Color_scheme.qualitative ~a:0.5 `Brewer_accent_8 () 14 | 15 | let frame_box ~src ~dst = (* fits and center *) 16 | let sy = Box2.h dst /. Box2.h src in 17 | let sx = Box2.w dst /. Box2.w src in 18 | let s, d = 19 | if sx < sy 20 | then sx, V2.v 0. (0.5 *. (Box2.h dst -. sx *. Box2.h src)) 21 | else sy, V2.v (0.5 *. (Box2.w dst -. sy *. Box2.w src)) 0. 22 | in 23 | M3.mul (M3.move2 V2.(Box2.o dst + d)) @@ 24 | M3.mul (M3.scale2 (V2.v s s)) @@ 25 | M3.move2 (V2.neg (Box2.o src)) 26 | 27 | let v_squares ~size ~gutter imgs = (* Start at P2.o and left-aligned on oy *) 28 | let rec loop size gutter ypos acc = function 29 | | [] -> Box2.v P2.o (Size2.v (Size2.w size) ypos), acc 30 | | (b, i) :: is -> 31 | let dst = Box2.v (V2.v 0. ypos) size in 32 | let tr = frame_box ~src:b ~dst in 33 | let acc = I.blend (I.tr tr i) acc in 34 | let ypos = ypos +. Size2.h size +. if is = [] then 0. else gutter in 35 | loop size gutter ypos acc is 36 | in 37 | loop size gutter 0. I.void imgs 38 | 39 | let h_squares ~size ~gutter imgs = (* Start at P2.o and bottom-aligned on ox *) 40 | let rec loop size gutter xpos acc = function 41 | | [] -> Box2.v P2.o (Size2.v xpos (Size2.h size)), acc 42 | | (b, i) :: is -> 43 | let dst = Box2.v (V2.v xpos 0.) size in 44 | let tr = frame_box ~src:b ~dst in 45 | let acc = I.blend (I.tr tr i) acc in 46 | let xpos = xpos +. Size2.w size +. if is = [] then 0. else gutter in 47 | loop size gutter xpos acc is 48 | in 49 | loop size gutter 0. I.void imgs 50 | 51 | let v_stack ~gutter imgs = (* Start at P2.o and left-aligned on oy *) 52 | let rec loop gutter maxw pos acc = function 53 | | [] -> Box2.v P2.o (Size2.v maxw (P2.y pos)), acc 54 | | (b, i) :: is -> 55 | let tr = V2.(pos - Box2.o b) in 56 | let acc = I.blend (I.move tr i) acc in 57 | let dy = Box2.h b +. if is = [] then 0. else gutter in 58 | let pos = V2.v (P2.x pos) (P2.y pos +. dy) in 59 | let maxw = Float.max maxw (Box2.w b) in 60 | loop gutter maxw pos acc is 61 | in 62 | loop gutter Float.min_float P2.o I.void imgs 63 | 64 | (* Geometry images *) 65 | 66 | let cut_pt ~w pt color = 67 | let p = P.empty |> P.circle pt (0.5 *. w) in 68 | let outline = `O { P.o with width = 0.15 *. 0.5 *. w } in 69 | let full = Color.with_a color 1.0 in 70 | I.cut p (I.const color) |> I.blend (I.cut ~area:outline p (I.const full)) 71 | 72 | let ring_path ?(acc = P.empty) c = 73 | let add pt p = if p == acc then P.sub pt p else P.line pt p in 74 | P.close (Ring2.fold_pts add c acc) 75 | 76 | let pgon_path p = 77 | let add c path = ring_path c ~acc:path in 78 | Pgon2.fold_rings add p P.empty 79 | 80 | let cut_pgon ?(area = `Aeo) ?(o = I.const Color.black) ~w:width p i = 81 | let p = pgon_path p and outline = `O { P.o with width } in 82 | I.cut ~area p i |> I.blend (I.cut ~area:outline p o) 83 | 84 | let cut_box ~w:width b color = 85 | let outline = `O { P.o with width } in 86 | I.cut ~area:outline (P.rect b P.empty) (I.const color) 87 | 88 | let cut_seg ~w:width p0 p1 color = 89 | let area = `O { P.o with width } in 90 | I.cut ~area (P.empty |> P.sub p0 |> P.line p1) (I.const color) 91 | 92 | (* Test images *) 93 | 94 | let errs = ref 0 95 | let retract loc doc op = function 96 | | Ok (v, _) -> v 97 | | Error ((v, _), err) -> 98 | let op = match op with 99 | | `Union -> "union" | `Inter -> "inter" | `Diff -> "diff" | `Xor -> "xor" 100 | in 101 | let err = match err with 102 | | `Edge_overlap -> "Edge overlap in input" 103 | | `Topology_panic msg -> msg 104 | in 105 | let doc = if doc <> "" then doc ^ "\n" else "" in 106 | incr errs; Fmt.pr "%s: %s %a\n%s%!" loc op Fmt.lines err doc; v 107 | 108 | let test (loc, a, b, _, doc) = 109 | try 110 | let box = Box2.union (Pgon2.box a) (Pgon2.box b) in 111 | let w = 0.005 *. Float.min (Box2.w box) (Box2.h box) in 112 | let cut_arg col p = 113 | let o = I.const (Color.with_a col 1.0) and a = I.const col in 114 | cut_pgon ~w:(2. *. w) ~o p a 115 | in 116 | let cut_op ?area p = cut_pgon ~w p (I.const (Color.gray 0.9)) in 117 | let src = box, (cut_arg (qual 0) a) |> I.blend (cut_arg (qual 1) b) in 118 | let u = box, cut_op (retract loc doc `Union (Pgon2.union a b)) in 119 | let i = box, cut_op (retract loc doc `Inter (Pgon2.inter a b)) in 120 | let d = box, cut_op (retract loc doc `Diff (Pgon2.diff a b)) in 121 | let x = box, cut_op (retract loc doc `Xor (Pgon2.xor a b)) in 122 | h_squares ~size:Size2.unit ~gutter:0.25 [src; u; i; d; x] 123 | with exn -> 124 | let bt = Printexc.get_raw_backtrace () in 125 | incr errs; 126 | Fmt.pr "@[%s: raised@,%a@]" loc Fmt.exn_backtrace (exn, bt); 127 | Box2.v P2.o Size2.zero, I.void 128 | 129 | let render r (view, img) = 130 | let aspect = Size2.aspect (Box2.size view) in 131 | let size = Size2.of_w 200. (* mm *) ~aspect in 132 | ignore (Vgr.render r (`Image (size, view, img))); 133 | ignore (Vgr.render r `End) 134 | 135 | let main () = 136 | let title = "Pgon bool" in 137 | let description = "Pgon boolean operators tests" in 138 | let xmp = Vgr.xmp ~title ~description () in 139 | let warn w = Vgr.pp_warning Format.err_formatter w in 140 | let file = "/tmp/pgon-test.pdf" in 141 | Out_channel.with_open_bin file @@ fun oc -> 142 | let r = Vgr.create ~warn (Vgr_pdf.target ~xmp ()) (`Channel oc) in 143 | let result _ m = 144 | if !errs > 0 145 | then m (format_of_string "%s tests failed") (string_of_int !errs) 146 | else m (format_of_string "%sSuccess!") "" 147 | in 148 | (Log.time ~level:Log.App result @@ fun () -> 149 | let img = 150 | let tests = List.rev_map test Pgon2_test_cases.list in 151 | let box, i = v_stack ~gutter:0.1 tests in 152 | Box2.outset (Size2.v 0.5 0.1) box, i 153 | in 154 | render r img); 155 | Printf.printf "Wrote %s\n%!" file; 156 | exit !errs 157 | 158 | let () = main () 159 | -------------------------------------------------------------------------------- /test/pgon2_test_cases.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2022 The gg programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | (* Test polygons for Pgon2 boolean operations *) 7 | 8 | let t000 = 9 | __LOC__, 10 | [[-0.5, 0.7; 0.5, -0.05; 1.5, 0.5]], 11 | [[0.0, 0.0; 0.5, 0.5; 1.0, 0.0]; 12 | [0.15, 0.06; 0.5, 0.4; 0.85, 0.06]], None, "" 13 | 14 | let t001 = 15 | __LOC__, 16 | [[0.0, 0.0; 1.0, 1.0; 2.0, 0.0]], 17 | [[0.0, 1.5; 1.0, 0.5; 2.0, 1.5]; 18 | [0.5, 1.3; 1.0, 0.7; 1.5, 1.3]], None, "" 19 | 20 | let t002 = 21 | __LOC__, 22 | [[0.0, 0.0; 1.0, 1.0; 2.0, 0.0]; 23 | [0.25, 0.1; 1.0, 0.8; 1.75, 0.1]], 24 | [[0.0, 0.75; 1.0, -0.25; 2.0, 0.75]; 25 | [0.5, 0.65; 1.0, -0.05; 1.5, 0.65]], None, "" 26 | 27 | let t003 = 28 | __LOC__, 29 | [[0.0, 0.75; 1.0, -0.25; 2.0, 0.75]; 30 | [0.5, 0.65; 1.0, -0.05; 1.5, 0.65]], 31 | [[0.0, 0.75; 1.0, -0.25; 2.0, 0.75]; 32 | [0.5, 0.65; 1.0, -0.05; 1.5, 0.65]], None, "Self" 33 | 34 | let t004 = 35 | __LOC__, 36 | [[0.0, 0.0; 0.5, 0.5; 1.0, 0.0]], 37 | [[0.5, 0.0; 0.5, -0.5; 1.5, 0.0]], None, "" 38 | 39 | let t005 = 40 | __LOC__, 41 | [[0.0, 0.0; -0.5, 0.5; 0.0, 1.]], 42 | [[0.0, 0.5; 0.5, 0.0; 0.0, -0.5]], None, "" 43 | 44 | let t006 = 45 | __LOC__, 46 | [[0.0, 0.0; 0.5, 0.5; 1.0, 0.0]], 47 | [[0.5, 0.0; 1.0, 0.5; 1.5, 0.0]], None, "" 48 | 49 | let t007 = 50 | __LOC__, 51 | [[-1.0, 0.0; 0.0, 1.0; 1.0, 0.0; 0.0, -1.0]], 52 | [[-1.0 +. 0.4, 0.4; -1.0 +. 0.6, 0.6; 0.1, 0.1; 0.1, -0.3; 53 | 0.5, -1.2; -1.2, -1.2; ]], None, "Paper fig. 3." 54 | 55 | let t008 = 56 | __LOC__, 57 | [[115.,96.; 140.,206.; 120.,210.; 125.,250.; 80.,300.]], 58 | [[111.,228.; 129.,192.; 309.,282.]], None, 59 | "From https://github.com/w8r/martinez/issues/110. Needs resort below (?)" 60 | 61 | let t009 = 62 | __LOC__, 63 | [[-1.0, 1.0; 1.0, -1.0; 1.0, 1.0]], 64 | [[0.0, 0.0; 0.0, 1.0; 1.0, 0.0]], None, "Resort below" 65 | 66 | let t010 = 67 | __LOC__, 68 | [[0.0, 0.0; 0.0, 1.0; 1.0, 0.0]], 69 | [[-1.0, 1.0; 1.0, -1.0; 1.0, 1.0]], None, "Resort below." 70 | 71 | let t011 = 72 | __LOC__, 73 | [[0x1.0a2281672d93bp+7, 0x1.90aa44afe878ep+7; 74 | 0x1.e04705a861e1p+6, 0x1.8eb724962322fp+7; 75 | 0x1.dc60c5df22622p+6, 0x1.90aa44afe878ep+7; 76 | 0x1.dc60c5df22622p+6, 0x1.929d64c9adcedp+7; 77 | 0x1.efe004cd5fdc8p+6, 0x1.9343c4d244eb7p+7; 78 | 0x1.f27984a8df867p+6, 0x1.929d64c9adcedp+7; 79 | 0x1.f7ac845fdeda4p+6, 0x1.929d64c9adcedp+7; 80 | 0x1.fa46043b5e843p+6, 0x1.929d64c9adcedp+7;]], 81 | [[0x1.0789018bade9cp+7, 0x1.9683a4fd387aap+7; 82 | 0x1.0595e1a70e2a5p+7, 0x1.9150a4b87f958p+7; 83 | 0x1.044921b94e556p+7, 0x1.90aa44afe878ep+7; 84 | 0x1.01afa1ddceab7p+7, 0x1.90aa44afe878ep+7; 85 | 0x1.0062e1f00ed68p+7, 0x1.90aa44afe878ep+7; 86 | 0x1.ff7903f25dd81p+6, 0x1.9150a4b87f958p+7; 87 | 0x1.f7ac845fdeda4p+6, 0x1.91f704c116b22p+7; 88 | 0x1.f51304845f306p+6, 0x1.91f704c116b22p+7; 89 | 0x1.efe004cd5fdc8p+6, 0x1.9343c4d244eb7p+7; 90 | 0x1.ed4684f1e0329p+6, 0x1.9536e4ec0a416p+7;]], None, 91 | "[seg_compare] needs a robust collinearity test" 92 | 93 | let t012 = 94 | __LOC__, 95 | [[0x1.b058e04960141p+8, 0x1.72ee9b26e71a9p+8; 96 | 0x1.ae129069505f6p+8, 0x1.74e1bb40ac708p+8; 97 | 0x1.b0ac1044d0095p+8, 0x1.777b3b6308e31p+8;]], 98 | [[0x1.b1df0ffbcf5d2p+8, 0x1.762e7b51daa9cp+8; 99 | 0x1.b152703baff3cp+8, 0x1.750e7b51daa9cp+8; 100 | 0x1.b005b04df01edp+8, 0x1.76d4db5a71c67p+8;]], None, "Resort above" 101 | 102 | let t013 = 103 | __LOC__, 104 | [[0x1.c864bef7bcf7dp+8, 0x1.0651298b4088p+9; 105 | 0x1.c5cb3f1c3d4dep+8, 0x1.08eaa9ad9cfa9p+9; 106 | 0x1.c90b1eee9ce25p+8, 0x1.08eaa9ad9cfa9p+9; 107 | 0x1.cc4afec0fc76bp+8, 0x1.05aac982a96b6p+9;]], 108 | [[0x1.caab0ed7ccac8p+8, 0x1.0581318083a44p+9; 109 | 0x1.c8b7eef32ced1p+8, 0x1.05d46184cf329p+9; 110 | 0x1.c8118efc4d029p+8, 0x1.0651298b4088p+9; 111 | 0x1.c8118efc4d029p+8, 0x1.06a4598f8c165p+9; 112 | 0x1.c90b1eee9ce25p+8, 0x1.0774519a48fa2p+9]], 113 | None, "Resort below" 114 | 115 | let t014 = 116 | __LOC__, 117 | [[0x1.2a77a7a131652p+8, 0x1.9f9ce5757c0bap+7; 118 | 0x1.2c6ac785d1249p+8, 0x1.9e5025644dd25p+7; 119 | 0x1.2cbdf7814119cp+8, 0x1.9da9c55bb6b5bp+7; 120 | 0x1.3051074f10a37p+8, 0x1.9536e4ec0a416p+7; 121 | 0x1.30a4374a8098bp+8, 0x1.8e10c48d8c065p+7; 122 | 0x1.3051074f10a37p+8, 0x1.8cc4047c5dcdp+7;]], 123 | [[0x1.32ea872a904d5p+8, 0x1.a190058f41618p+7; 124 | 0x1.3051074f10a37p+8, 0x1.9c5d054a887c6p+7; 125 | 0x1.2e0ab76f00eecp+8, 0x1.9c5d054a887c6p+7; 126 | 0x1.2c17978a612f5p+8, 0x1.9e5025644dd25p+7;]], 127 | None, "Divide left-right swap" 128 | 129 | let t015 = 130 | __LOC__, 131 | [[0x1.3668caf983d9bp+9, 0x1.ae65ee38e9d73p+8; 132 | 0x1.3545a3097bff5p+9, 0x1.b0ac3e56fabb7p+8; 133 | 0x1.370f2af063c42p+9, 0x1.b0cbeec25ba17p+8;]], 134 | [[0x1.363f32fbcbdf1p+9, 0x1.aeb91e3d35658p+8; 135 | 0x1.36bbfaf4f3cefp+9, 0x1.adbf8e3052ba9p+8; 136 | 0x1.35a59afe13e47p+9, 0x1.aeb91e3d35658p+8]], None, 137 | "Correct overlap inout; [seg_compare] when collinear a segment extends \ 138 | another (and maybe not exactly due to numerical errors." 139 | 140 | let t016 = 141 | __LOC__, 142 | [[0x1.a83930bb71211p+8, 0x1.56a949b139bcbp+8; 143 | 0x1.a932c0adc100cp+8, 0x1.57a2d9be1c67bp+8; 144 | 0x1.ab25e09260c03p+8, 0x1.58ef99cf4aa0fp+8;]], 145 | [[0x1.a8df90b2510b8p+8, 0x1.59e929dc2d4bfp+8; 146 | 0x1.a8df90b2510b8p+8, 0x1.57f609c267f6p+8; 147 | 0x1.a8df90b2510b8p+8, 0x1.574fa9b9d0d96p+8; 148 | 0x1.a83930bb71211p+8, 0x1.5602e9a8a2a01p+8;]], None, 149 | "[seg_compare] when collinear and horizontal prolongation." 150 | 151 | and t017 = 152 | __LOC__, 153 | [[0x1.24f177eec21cp+8, 0x1.8eb724962322fp+7; 154 | 0x1.249e47f35226cp+8, 0x1.8f5d849eba3f9p+7; 155 | 0x1.249e47f35226cp+8, 0x1.90aa44afe878ep+7;]], 156 | [[0x1.2544a7ea32114p+8, 0x1.90aa44afe878ep+7; 157 | 0x1.244b17f7e2319p+8, 0x1.8eb724962322fp+7; 158 | 0x1.23ab280eb2675p+8, 0x1.8f10c48d8c065p+7;]], 159 | Some ([9], [5], [3; 3], [9]), 160 | "Two segs of one triangle meet on the edge of another \ 161 | one but two different isect points are computed." 162 | 163 | and t018 = 164 | __LOC__, 165 | [[0x1.02bdfdcefa888p+9, 0x1.e460a9040de78p+7; 166 | 0x1.01ee05da62a36p+9, 0x1.e5cd69153c20cp+7; 167 | 0x1.0147a5e382b8fp+9, 0x1.e673c91dd33d7p+7;]], 168 | [[0x1.01c46ddcaaa8cp+9, 0x1.e673c91dd33d7p+7; 169 | 0x1.026acdd38a934p+9, 0x1.e3da48fb76caep+7; 170 | 0x1.025465d1428dep+9, 0x1.e28d88ea48919p+7;]], 171 | None, "Right order swap in divide" 172 | 173 | let t019 = 174 | __LOC__, 175 | [[0x1.026acdd38a934p+9, 0x1.e28d88ea48919p+7; 176 | 0x1.02179dd81a9ep+9, 0x1.e28d88ea48919p+7; 177 | 0x1.01ee05da62a36p+9, 0x1.e3da48fb76caep+7; 178 | 0x1.fe02ac06e6087p+8, 0x1.e71a29266a5a1p+7;]], 179 | [[0x1.01713de13ab38p+9, 0x1.e527090ca5042p+7; 180 | 0x1.026acdd38a934p+9, 0x1.e140c8d91a585p+7; 181 | 0x1.0077adeeead3dp+9, 0x1.e673c91dd33d7p+7]], 182 | None, "Unassigned below" 183 | 184 | let t020 = 185 | __LOC__, 186 | [[0x1.0882917dfdc98p+6, 0x1.73be9331a3fe6p+4; 187 | 0x1.0882917dfdc98p+6, 0x1.7e2493bb15c8ap+4; 188 | 0x1.060f91c6fe75bp+6, 0x1.757984b5cffcp+4;]], 189 | [[0x1.05c51b4be4aap+6, 0x1.7289959c240c8p+4; 190 | 0x1.0882917dfdc98p+6, 0x1.78f193765ce38p+4; 191 | 0x1.0882917dfdc98p+6, 0x1.70f390c723f04p+4;]], 192 | None, "" 193 | 194 | let t021 = 195 | __LOC__, 196 | [[0x1.d5e1063a63395p+6, 0x1.07d5ddac8a17p+7; 197 | 0x1.ddad85cce2371p+6, 0x1.082f7da3f2fa6p+7; 198 | 0x1.ebf9c504205dap+6, 0x1.01095d4574bf5p+7;]], 199 | [[0x1.e42d4571a15fep+6, 0x1.0595fd819687dp+7; 200 | 0x1.e04705a861e1p+6, 0x1.06e2bd92c4c11p+7; 201 | 0x1.db1405f1628d2p+6, 0x1.07891d9b5bddcp+7;]], None, 202 | "Need field recompute on right overlap" 203 | 204 | let t022 = 205 | __LOC__, 206 | [[0x1.39a8aacbe36e1p+9, 0x1.ae65ee38e9d73p+8; 207 | 0x1.39557ad07378dp+9, 0x1.aeb91e3d35658p+8; 208 | 0x1.38af1ad9938e6p+9, 0x1.aeb91e3d35658p+8;]], 209 | [[0x1.39024ad50383ap+9, 0x1.af0c4e4180f3dp+8; 210 | 0x1.39a8aacbe36e1p+9, 0x1.ae65ee38e9d73p+8; 211 | 0x1.39fbdac753635p+9, 0x1.ae12be349e48ep+8; 212 | 0x1.39fbdac753635p+9, 0x1.ad6c5e2c072c3p+8;]], None, "" 213 | 214 | let t023 = 215 | __LOC__, 216 | [[0x1.755e5b857fb4fp+7, 0x1.0504697a124ecp+9; 217 | 0x1.7b37bb335ef35p+7, 0x1.06cdf191b1dd8p+9; 218 | 0x1.7dd13b0ede9d3p+7, 0x1.0774519a48fa2p+9;]], 219 | [[0x1.7ec45af37e5cap+7, 0x1.079de99c6ec15p+9; 220 | 0x1.7c847b211ec84p+7, 0x1.07212195fd6bdp+9; 221 | 0x1.7bde1b2a3eddcp+7, 0x1.06f78993d7a4bp+9; 222 | 0x1.79449b4ebf33dp+7, 0x1.06f78993d7a4bp+9;]], None, "" 223 | 224 | let t024 = 225 | __LOC__, 226 | [[0x1.cbf7cec58c817p+8, 0x1.05aac982a96b6p+9; 227 | 0x1.caab0ed7ccac8p+8, 0x1.05d46184cf329p+9; 228 | 0x1.ca57dedc5cb74p+8, 0x1.05fdf986f4f9bp+9; 229 | 0x1.ca04aee0ecc2p+8, 0x1.0651298b4088p+9;]], 230 | [[0x1.ca04aee0ecc2p+8, 0x1.062791891ac0ep+9; 231 | 0x1.cafe3ed33ca1cp+8, 0x1.05aac982a96b6p+9; 232 | 0x1.ca816eceac97p+8, 0x1.055ad177ec879p+9;]], 233 | None, "We miss the overlap and think that the triangle below is above." 234 | 235 | let t025 = 236 | __LOC__, 237 | [[0x1.702b5bce80612p+7, 0x1.ab260e0df648p+8; 238 | 0x1.5f459cbbc290ap+7, 0x1.af5f7e45cc822p+8; 239 | 0x1.632bdc85020f8p+7, 0x1.b345be79572ep+8; ]], 240 | [[0x1.63d23c7be1fap+7, 0x1.b3ec1e81ee4aap+8; 241 | 0x1.62857c8e2225p+7, 0x1.b29f5e70c0115p+8; 242 | 0x1.62857c8e2225p+7, 0x1.b1f8fe6828f4bp+8; 243 | 0x1.5a129d04c33cdp+7, 0x1.b1b2ae4a18107p+8;]], None, "" 244 | 245 | let t026 = 246 | __LOC__, 247 | [[0x1.5029658fec84fp+8, 0x1.726473e60957dp+6; 248 | 0x1.53161566dc242p+8, 0x1.707eb306b06f3p+6; 249 | 0x1.52c2e56b6c2eep+8, 0x1.6f31f2f58235ep+6; 250 | 0x1.536945624c196p+8, 0x1.64cbf26c106bap+6;]], 251 | [[0x1.526fb56ffc39ap+8, 0x1.6ab2329f9b178p+6; 252 | 0x1.526fb56ffc39ap+8, 0x1.6de532e453fcap+6; 253 | 0x1.536945624c196p+8, 0x1.71cb7317dea87p+6;]], None, "Overlap" 254 | 255 | let t027 = 256 | __LOC__, 257 | [[ 0.0, 0.0; 1.0, 0.0; 1.0, 1.0; 0.0, 1.0]], 258 | [[ 0.25, 0.3; 0.75, 0.3; 0.75, 1.0; 0.25, 1.0]], 259 | None, "Overlap test, fig. 10. 2013 paper" 260 | 261 | let t028 = 262 | __LOC__, 263 | [[ 0.0, 0.0; 1.0, 0.0; 1.0, 1.0; 0.0, 1.0]], 264 | [[ 0.25, 1.0; 0.75, 1.0; 0.75, 1.75; 0.25, 1.75]], 265 | None, "Overlap test, fig. 10. 2013 paper" 266 | 267 | let make_test (loc, a, b, ops, doc) = 268 | let pt (x, y) = Gg.P2.v x y in 269 | let ring ps = Gg_kit.Ring2.of_pts (List.map pt ps) in 270 | let pgon cs = Gg_kit.Pgon2.of_rings (List.map ring cs) in 271 | loc, pgon a, pgon b, ops, doc 272 | 273 | let list = List.rev_map make_test 274 | [ t000; t001; t002; t003; t004; t005; t006; t007; t008; t009; t010; 275 | t011; t012; t013; t014; t015; t016; t017; t018; t019; t020; 276 | t021; t022; t023; t026; t027; t028; t025; t024] 277 | -------------------------------------------------------------------------------- /test/test_color_scheme.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2022 The gg programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | open B0_testing 7 | 8 | open Gg 9 | open Gg_kit 10 | 11 | (* Colors *) 12 | 13 | let str = Format.sprintf 14 | 15 | let eqf v v' = 16 | if v = v' then () else 17 | Test.log_fail "%f (%a) = %f (%a)" v Float.pp v v' Float.pp v' 18 | 19 | let irange ?(min = 0.) ?(max = 1.) ~dt f = 20 | let n = truncate (((max -. min) /. dt) +. 1.) in 21 | let maxi = n - 1 in 22 | let rec loop i = 23 | if i < maxi then (f (min +. (float i) *. dt); loop (i + 1)) else f max 24 | in 25 | if max = min then f max else 26 | (f min; loop 1) 27 | 28 | let ( >>= ) f x = f x 29 | 30 | (* internal function, test passed 31 | 32 | let test_msc () = 33 | let test_edge c = 34 | irange ~min:0. ~max:1. ~dt:0.01 >>= fun t -> 35 | let c = c t in 36 | let _, _, h, _ = V4.to_tuple (Color.to_luva ~lch:true c) in 37 | let c' = Colors.msc h in 38 | if not (V4.equal_f (Float.equal_tol ~eps:1.e-9) c c') then 39 | fail "%a != %a\n" V4.pp c V4.pp c'; 40 | in 41 | test_edge (fun t -> Color.v t 1. 0. 1.); 42 | test_edge (fun t -> Color.v t 0. 1. 1.); 43 | test_edge (fun t -> Color.v 0. t 1. 1.); 44 | test_edge (fun t -> Color.v 1. t 0. 1.); 45 | test_edge (fun t -> Color.v 0. 1. t 1.); 46 | test_edge (fun t -> Color.v 1. 0. t 1.) 47 | *) 48 | 49 | let test_color_seq = 50 | Test.test "Sequential color schemes do not NaN" @@ fun () -> 51 | irange ~min:0. ~max:359. ~dt:1. >>= fun h -> 52 | irange ~min:0. ~max:1. ~dt:0.1 >>= fun w -> 53 | irange ~min:0. ~max:1. ~dt:0.1 >>= fun s -> 54 | irange ~min:0. ~max:1. ~dt:0.1 >>= fun b -> 55 | irange ~min:0. ~max:1. ~dt:0.1 >>= fun c -> 56 | let cs = 57 | Color_scheme.sequential_wijffelaars 58 | ~w ~s ~b ~c ~h:(Float.rad_of_deg h) () 59 | in 60 | irange ~min:0. ~max:1. ~dt:1. >>= fun t -> 61 | let color = cs t in 62 | let urange d = 0. <= d && d <= 1. in 63 | if V4.for_all urange color then () else 64 | let cr, cg, cb, ca = V4.to_tuple color in 65 | Test.log_fail "not in rgb cube w:%g s:%g b:%g c:%g h:%g t:%g \ 66 | (%.16f %.16f %.16f)" 67 | w s b c h t cr cg cb; assert true 68 | 69 | let test_qual = 70 | Test.test "Qualitative color schemes do not NaN" @@ fun () -> 71 | irange ~min:0. ~max:1. ~dt:0.1 >>= fun eps -> 72 | irange ~min:0. ~max:1. ~dt:0.1 >>= fun r -> 73 | irange ~min:0. ~max:1. ~dt:0.1 >>= fun s -> 74 | irange ~min:0. ~max:1. ~dt:0.1 >>= fun b -> 75 | irange ~min:0. ~max:1. ~dt:0.1 >>= fun c -> 76 | let size = 16 in 77 | let q = Color_scheme.qualitative_wijffelaars ~size () in 78 | for i = 0 to size - 1 do 79 | let color = q i in 80 | let urange d = 0. <= d && d <= 1. in 81 | if V4.for_all urange color then () else 82 | let cr, cg, cb, _ = V4.to_tuple color in 83 | Test.log_fail 84 | "qualitative color not in rgb cube eps:%g r:%g s:%g b:%g c:%g \ 85 | (%.16f %.16f %.16f)" 86 | eps r s b c cr cg cb 87 | done 88 | 89 | let main () = 90 | Test.main @@ fun () -> 91 | Test.log "Be patient…"; 92 | Test.autorun (); 93 | () 94 | 95 | let () = if !Sys.interactive then () else exit (main ()) 96 | -------------------------------------------------------------------------------- /test/test_ring2.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2024 The gg programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | open B0_testing 7 | 8 | open Gg 9 | open Gg_kit 10 | 11 | let rect_cw = Ring2.of_pts [P2.o; P2.v 3. 0.; P2.v 3. 2.; P2.v 0. 2.] 12 | let sq_cw = Ring2.of_pts [P2.o; P2.v 2. 0.; P2.v 2. 2.; P2.v 0. 2.] 13 | 14 | let test_area = 15 | Test.test "Ring2.{area,swap_orientation}" @@ fun () -> 16 | Test.float 0. (Ring2.area Ring2.empty); 17 | Test.float 4. (Ring2.area sq_cw); 18 | Test.float (-4.) (Ring2.area @@ Ring2.swap_orientation sq_cw); 19 | Test.float 6. (Ring2.area rect_cw); 20 | Test.float ~-.6. (Ring2.area @@ Ring2.swap_orientation rect_cw); 21 | () 22 | 23 | let main () = Test.main @@ fun () -> Test.autorun () 24 | let () = if !Sys.interactive then () else exit (main ()) 25 | --------------------------------------------------------------------------------