├── .github └── workflows │ └── main.yml ├── .gitignore ├── .merlin ├── CHANGES.md ├── LICENSE.md ├── Makefile ├── README.md ├── curve-sampling.opam ├── demo ├── dune └── graphs.ml ├── dune-project ├── src ├── PQ.ml ├── PQ.mli ├── curve_sampling.ml ├── curve_sampling.mli └── dune └── tests ├── abs.gp ├── abs.ml ├── clip.gp ├── clip.ml ├── clip.tex ├── dom.gp ├── dom.ml ├── dune ├── empty.ml ├── horror.ml ├── latex_speed.ml ├── nice.gp ├── nice.ml ├── osc.gp ├── osc.ml └── sequences.ml /.github/workflows/main.yml: -------------------------------------------------------------------------------- 1 | name: Continuous Integration 2 | 3 | on: 4 | push: 5 | branches: [ master ] 6 | pull_request: 7 | branches: [ master ] 8 | 9 | jobs: 10 | build: 11 | strategy: 12 | fail-fast: false 13 | matrix: 14 | os: 15 | - macos-latest 16 | - ubuntu-latest 17 | - windows-latest 18 | ocaml-version: 19 | - 4.12.0 20 | include: 21 | - ocaml-version: 4.03.0 22 | os: ubuntu-latest 23 | skip_test: true 24 | - ocaml-version: 4.08.1 25 | os: ubuntu-latest 26 | skip_test: true 27 | - ocaml-version: 4.11.1 28 | os: ubuntu-latest 29 | skip_test: true 30 | - ocaml-version: 4.13.0 31 | os: ubuntu-latest 32 | skip_test: true 33 | - ocaml-version: 4.13.0 34 | arch: armv6 35 | os: ubuntu-latest 36 | 37 | runs-on: ${{ matrix.os }} 38 | 39 | env: 40 | SKIP_TEST: ${{ matrix.skip_test }} 41 | 42 | steps: 43 | - name: Checkout code 44 | uses: actions/checkout@v2 45 | - name: Set up OCaml ${{ matrix.ocaml-version }} 46 | uses: ocaml/setup-ocaml@v2 47 | with: 48 | ocaml-compiler: ${{ matrix.ocaml-version }} 49 | 50 | - run: sudo apt-get install gnuplot-x11 51 | if: matrix.os == 'ubuntu-latest' 52 | - run: brew install gnuplot gsl && opam install gsl 53 | if: matrix.os == 'macos-latest' 54 | - run: opam install . --deps-only --with-test 55 | - run: opam exec -- dune build @install 56 | - name: run test suite 57 | run: opam exec -- dune build @runtest 58 | if: env.SKIP_TEST != 'true' && matrix.os != 'windows-latest' 59 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _build/ 2 | .merlin 3 | *.install 4 | biblio/ 5 | TODO.md 6 | *.png 7 | -------------------------------------------------------------------------------- /.merlin: -------------------------------------------------------------------------------- 1 | PKG gg 2 | S src 3 | B _build/src 4 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | 0.2.1 2021-11-12 2 | ---------------- 3 | 4 | - New functions `is_empty` and `bounding_box`. 5 | - Do not fail on empty samplings. 6 | 7 | 0.2 2019-12-08 8 | -------------- 9 | 10 | - New function `to_latex_channel`. 11 | - Allow to specify the color when converting to LaTeX. 12 | - Automatically divide the path into several PGF/TikZ paths when it is 13 | too long for LaTeX capacity. This is configurable. 14 | - LaTeX output can draw arrows on paths. 15 | - Improve the sampling procedure: better determine the slope at 16 | endpoints, be less reactive to small zigzags that may be due to 17 | rough estimates, and use viewport scaling to estimate all costs. 18 | - Use an internal random state and not the global one. 19 | 20 | 0.1 2018-11-28 21 | -------------- 22 | 23 | - Initial release 24 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | ### GNU GENERAL PUBLIC LICENSE 2 | 3 | Version 3, 29 June 2007 4 | 5 | Copyright (C) 2007 Free Software Foundation, Inc. 6 | 7 | 8 | Everyone is permitted to copy and distribute verbatim copies of this 9 | license document, but changing it is not allowed. 10 | 11 | ### Preamble 12 | 13 | The GNU General Public License is a free, copyleft license for 14 | software and other kinds of works. 15 | 16 | The licenses for most software and other practical works are designed 17 | to take away your freedom to share and change the works. By contrast, 18 | the GNU General Public License is intended to guarantee your freedom 19 | to share and change all versions of a program--to make sure it remains 20 | free software for all its users. We, the Free Software Foundation, use 21 | the GNU General Public License for most of our software; it applies 22 | also to any other work released this way by its authors. You can apply 23 | it to your programs, too. 24 | 25 | When we speak of free software, we are referring to freedom, not 26 | price. Our General Public Licenses are designed to make sure that you 27 | have the freedom to distribute copies of free software (and charge for 28 | them if you wish), that you receive source code or can get it if you 29 | want it, that you can change the software or use pieces of it in new 30 | free programs, and that you know you can do these things. 31 | 32 | To protect your rights, we need to prevent others from denying you 33 | these rights or asking you to surrender the rights. Therefore, you 34 | have certain responsibilities if you distribute copies of the 35 | software, or if you modify it: responsibilities to respect the freedom 36 | of others. 37 | 38 | For example, if you distribute copies of such a program, whether 39 | gratis or for a fee, you must pass on to the recipients the same 40 | freedoms that you received. You must make sure that they, too, receive 41 | or can get the source code. And you must show them these terms so they 42 | know their rights. 43 | 44 | Developers that use the GNU GPL protect your rights with two steps: 45 | (1) assert copyright on the software, and (2) offer you this License 46 | giving you legal permission to copy, distribute and/or modify it. 47 | 48 | For the developers' and authors' protection, the GPL clearly explains 49 | that there is no warranty for this free software. For both users' and 50 | authors' sake, the GPL requires that modified versions be marked as 51 | changed, so that their problems will not be attributed erroneously to 52 | authors of previous versions. 53 | 54 | Some devices are designed to deny users access to install or run 55 | modified versions of the software inside them, although the 56 | manufacturer can do so. This is fundamentally incompatible with the 57 | aim of protecting users' freedom to change the software. The 58 | systematic pattern of such abuse occurs in the area of products for 59 | individuals to use, which is precisely where it is most unacceptable. 60 | Therefore, we have designed this version of the GPL to prohibit the 61 | practice for those products. If such problems arise substantially in 62 | other domains, we stand ready to extend this provision to those 63 | domains in future versions of the GPL, as needed to protect the 64 | freedom of users. 65 | 66 | Finally, every program is threatened constantly by software patents. 67 | States should not allow patents to restrict development and use of 68 | software on general-purpose computers, but in those that do, we wish 69 | to avoid the special danger that patents applied to a free program 70 | could make it effectively proprietary. To prevent this, the GPL 71 | assures that patents cannot be used to render the program non-free. 72 | 73 | The precise terms and conditions for copying, distribution and 74 | modification follow. 75 | 76 | ### TERMS AND CONDITIONS 77 | 78 | #### 0. Definitions. 79 | 80 | "This License" refers to version 3 of the GNU General Public License. 81 | 82 | "Copyright" also means copyright-like laws that apply to other kinds 83 | of works, such as semiconductor masks. 84 | 85 | "The Program" refers to any copyrightable work licensed under this 86 | License. Each licensee is addressed as "you". "Licensees" and 87 | "recipients" may be individuals or organizations. 88 | 89 | To "modify" a work means to copy from or adapt all or part of the work 90 | in a fashion requiring copyright permission, other than the making of 91 | an exact copy. The resulting work is called a "modified version" of 92 | the earlier work or a work "based on" the earlier work. 93 | 94 | A "covered work" means either the unmodified Program or a work based 95 | on the Program. 96 | 97 | To "propagate" a work means to do anything with it that, without 98 | permission, would make you directly or secondarily liable for 99 | infringement under applicable copyright law, except executing it on a 100 | computer or modifying a private copy. Propagation includes copying, 101 | distribution (with or without modification), making available to the 102 | public, and in some countries other activities as well. 103 | 104 | To "convey" a work means any kind of propagation that enables other 105 | parties to make or receive copies. Mere interaction with a user 106 | through a computer network, with no transfer of a copy, is not 107 | conveying. 108 | 109 | An interactive user interface displays "Appropriate Legal Notices" to 110 | the extent that it includes a convenient and prominently visible 111 | feature that (1) displays an appropriate copyright notice, and (2) 112 | tells the user that there is no warranty for the work (except to the 113 | extent that warranties are provided), that licensees may convey the 114 | work under this License, and how to view a copy of this License. If 115 | the interface presents a list of user commands or options, such as a 116 | menu, a prominent item in the list meets this criterion. 117 | 118 | #### 1. Source Code. 119 | 120 | The "source code" for a work means the preferred form of the work for 121 | making modifications to it. "Object code" means any non-source form of 122 | a work. 123 | 124 | A "Standard Interface" means an interface that either is an official 125 | standard defined by a recognized standards body, or, in the case of 126 | interfaces specified for a particular programming language, one that 127 | is widely used among developers working in that language. 128 | 129 | The "System Libraries" of an executable work include anything, other 130 | than the work as a whole, that (a) is included in the normal form of 131 | packaging a Major Component, but which is not part of that Major 132 | Component, and (b) serves only to enable use of the work with that 133 | Major Component, or to implement a Standard Interface for which an 134 | implementation is available to the public in source code form. A 135 | "Major Component", in this context, means a major essential component 136 | (kernel, window system, and so on) of the specific operating system 137 | (if any) on which the executable work runs, or a compiler used to 138 | produce the work, or an object code interpreter used to run it. 139 | 140 | The "Corresponding Source" for a work in object code form means all 141 | the source code needed to generate, install, and (for an executable 142 | work) run the object code and to modify the work, including scripts to 143 | control those activities. However, it does not include the work's 144 | System Libraries, or general-purpose tools or generally available free 145 | programs which are used unmodified in performing those activities but 146 | which are not part of the work. For example, Corresponding Source 147 | includes interface definition files associated with source files for 148 | the work, and the source code for shared libraries and dynamically 149 | linked subprograms that the work is specifically designed to require, 150 | such as by intimate data communication or control flow between those 151 | subprograms and other parts of the work. 152 | 153 | The Corresponding Source need not include anything that users can 154 | regenerate automatically from other parts of the Corresponding Source. 155 | 156 | The Corresponding Source for a work in source code form is that same 157 | work. 158 | 159 | #### 2. Basic Permissions. 160 | 161 | All rights granted under this License are granted for the term of 162 | copyright on the Program, and are irrevocable provided the stated 163 | conditions are met. This License explicitly affirms your unlimited 164 | permission to run the unmodified Program. The output from running a 165 | covered work is covered by this License only if the output, given its 166 | content, constitutes a covered work. This License acknowledges your 167 | rights of fair use or other equivalent, as provided by copyright law. 168 | 169 | You may make, run and propagate covered works that you do not convey, 170 | without conditions so long as your license otherwise remains in force. 171 | You may convey covered works to others for the sole purpose of having 172 | them make modifications exclusively for you, or provide you with 173 | facilities for running those works, provided that you comply with the 174 | terms of this License in conveying all material for which you do not 175 | control copyright. Those thus making or running the covered works for 176 | you must do so exclusively on your behalf, under your direction and 177 | control, on terms that prohibit them from making any copies of your 178 | copyrighted material outside their relationship with you. 179 | 180 | Conveying under any other circumstances is permitted solely under the 181 | conditions stated below. Sublicensing is not allowed; section 10 makes 182 | it unnecessary. 183 | 184 | #### 3. Protecting Users' Legal Rights From Anti-Circumvention Law. 185 | 186 | No covered work shall be deemed part of an effective technological 187 | measure under any applicable law fulfilling obligations under article 188 | 11 of the WIPO copyright treaty adopted on 20 December 1996, or 189 | similar laws prohibiting or restricting circumvention of such 190 | measures. 191 | 192 | When you convey a covered work, you waive any legal power to forbid 193 | circumvention of technological measures to the extent such 194 | circumvention is effected by exercising rights under this License with 195 | respect to the covered work, and you disclaim any intention to limit 196 | operation or modification of the work as a means of enforcing, against 197 | the work's users, your or third parties' legal rights to forbid 198 | circumvention of technological measures. 199 | 200 | #### 4. Conveying Verbatim Copies. 201 | 202 | You may convey verbatim copies of the Program's source code as you 203 | receive it, in any medium, provided that you conspicuously and 204 | appropriately publish on each copy an appropriate copyright notice; 205 | keep intact all notices stating that this License and any 206 | non-permissive terms added in accord with section 7 apply to the code; 207 | keep intact all notices of the absence of any warranty; and give all 208 | recipients a copy of this License along with the Program. 209 | 210 | You may charge any price or no price for each copy that you convey, 211 | and you may offer support or warranty protection for a fee. 212 | 213 | #### 5. Conveying Modified Source Versions. 214 | 215 | You may convey a work based on the Program, or the modifications to 216 | produce it from the Program, in the form of source code under the 217 | terms of section 4, provided that you also meet all of these 218 | conditions: 219 | 220 | - a) The work must carry prominent notices stating that you modified 221 | it, and giving a relevant date. 222 | - b) The work must carry prominent notices stating that it is 223 | released under this License and any conditions added under 224 | section 7. This requirement modifies the requirement in section 4 225 | to "keep intact all notices". 226 | - c) You must license the entire work, as a whole, under this 227 | License to anyone who comes into possession of a copy. This 228 | License will therefore apply, along with any applicable section 7 229 | additional terms, to the whole of the work, and all its parts, 230 | regardless of how they are packaged. This License gives no 231 | permission to license the work in any other way, but it does not 232 | invalidate such permission if you have separately received it. 233 | - d) If the work has interactive user interfaces, each must display 234 | Appropriate Legal Notices; however, if the Program has interactive 235 | interfaces that do not display Appropriate Legal Notices, your 236 | work need not make them do so. 237 | 238 | A compilation of a covered work with other separate and independent 239 | works, which are not by their nature extensions of the covered work, 240 | and which are not combined with it such as to form a larger program, 241 | in or on a volume of a storage or distribution medium, is called an 242 | "aggregate" if the compilation and its resulting copyright are not 243 | used to limit the access or legal rights of the compilation's users 244 | beyond what the individual works permit. Inclusion of a covered work 245 | in an aggregate does not cause this License to apply to the other 246 | parts of the aggregate. 247 | 248 | #### 6. Conveying Non-Source Forms. 249 | 250 | You may convey a covered work in object code form under the terms of 251 | sections 4 and 5, provided that you also convey the machine-readable 252 | Corresponding Source under the terms of this License, in one of these 253 | ways: 254 | 255 | - a) Convey the object code in, or embodied in, a physical product 256 | (including a physical distribution medium), accompanied by the 257 | Corresponding Source fixed on a durable physical medium 258 | customarily used for software interchange. 259 | - b) Convey the object code in, or embodied in, a physical product 260 | (including a physical distribution medium), accompanied by a 261 | written offer, valid for at least three years and valid for as 262 | long as you offer spare parts or customer support for that product 263 | model, to give anyone who possesses the object code either (1) a 264 | copy of the Corresponding Source for all the software in the 265 | product that is covered by this License, on a durable physical 266 | medium customarily used for software interchange, for a price no 267 | more than your reasonable cost of physically performing this 268 | conveying of source, or (2) access to copy the Corresponding 269 | Source from a network server at no charge. 270 | - c) Convey individual copies of the object code with a copy of the 271 | written offer to provide the Corresponding Source. This 272 | alternative is allowed only occasionally and noncommercially, and 273 | only if you received the object code with such an offer, in accord 274 | with subsection 6b. 275 | - d) Convey the object code by offering access from a designated 276 | place (gratis or for a charge), and offer equivalent access to the 277 | Corresponding Source in the same way through the same place at no 278 | further charge. You need not require recipients to copy the 279 | Corresponding Source along with the object code. If the place to 280 | copy the object code is a network server, the Corresponding Source 281 | may be on a different server (operated by you or a third party) 282 | that supports equivalent copying facilities, provided you maintain 283 | clear directions next to the object code saying where to find the 284 | Corresponding Source. Regardless of what server hosts the 285 | Corresponding Source, you remain obligated to ensure that it is 286 | available for as long as needed to satisfy these requirements. 287 | - e) Convey the object code using peer-to-peer transmission, 288 | provided you inform other peers where the object code and 289 | Corresponding Source of the work are being offered to the general 290 | public at no charge under subsection 6d. 291 | 292 | A separable portion of the object code, whose source code is excluded 293 | from the Corresponding Source as a System Library, need not be 294 | included in conveying the object code work. 295 | 296 | A "User Product" is either (1) a "consumer product", which means any 297 | tangible personal property which is normally used for personal, 298 | family, or household purposes, or (2) anything designed or sold for 299 | incorporation into a dwelling. In determining whether a product is a 300 | consumer product, doubtful cases shall be resolved in favor of 301 | coverage. For a particular product received by a particular user, 302 | "normally used" refers to a typical or common use of that class of 303 | product, regardless of the status of the particular user or of the way 304 | in which the particular user actually uses, or expects or is expected 305 | to use, the product. A product is a consumer product regardless of 306 | whether the product has substantial commercial, industrial or 307 | non-consumer uses, unless such uses represent the only significant 308 | mode of use of the product. 309 | 310 | "Installation Information" for a User Product means any methods, 311 | procedures, authorization keys, or other information required to 312 | install and execute modified versions of a covered work in that User 313 | Product from a modified version of its Corresponding Source. The 314 | information must suffice to ensure that the continued functioning of 315 | the modified object code is in no case prevented or interfered with 316 | solely because modification has been made. 317 | 318 | If you convey an object code work under this section in, or with, or 319 | specifically for use in, a User Product, and the conveying occurs as 320 | part of a transaction in which the right of possession and use of the 321 | User Product is transferred to the recipient in perpetuity or for a 322 | fixed term (regardless of how the transaction is characterized), the 323 | Corresponding Source conveyed under this section must be accompanied 324 | by the Installation Information. But this requirement does not apply 325 | if neither you nor any third party retains the ability to install 326 | modified object code on the User Product (for example, the work has 327 | been installed in ROM). 328 | 329 | The requirement to provide Installation Information does not include a 330 | requirement to continue to provide support service, warranty, or 331 | updates for a work that has been modified or installed by the 332 | recipient, or for the User Product in which it has been modified or 333 | installed. Access to a network may be denied when the modification 334 | itself materially and adversely affects the operation of the network 335 | or violates the rules and protocols for communication across the 336 | network. 337 | 338 | Corresponding Source conveyed, and Installation Information provided, 339 | in accord with this section must be in a format that is publicly 340 | documented (and with an implementation available to the public in 341 | source code form), and must require no special password or key for 342 | unpacking, reading or copying. 343 | 344 | #### 7. Additional Terms. 345 | 346 | "Additional permissions" are terms that supplement the terms of this 347 | License by making exceptions from one or more of its conditions. 348 | Additional permissions that are applicable to the entire Program shall 349 | be treated as though they were included in this License, to the extent 350 | that they are valid under applicable law. If additional permissions 351 | apply only to part of the Program, that part may be used separately 352 | under those permissions, but the entire Program remains governed by 353 | this License without regard to the additional permissions. 354 | 355 | When you convey a copy of a covered work, you may at your option 356 | remove any additional permissions from that copy, or from any part of 357 | it. (Additional permissions may be written to require their own 358 | removal in certain cases when you modify the work.) You may place 359 | additional permissions on material, added by you to a covered work, 360 | for which you have or can give appropriate copyright permission. 361 | 362 | Notwithstanding any other provision of this License, for material you 363 | add to a covered work, you may (if authorized by the copyright holders 364 | of that material) supplement the terms of this License with terms: 365 | 366 | - a) Disclaiming warranty or limiting liability differently from the 367 | terms of sections 15 and 16 of this License; or 368 | - b) Requiring preservation of specified reasonable legal notices or 369 | author attributions in that material or in the Appropriate Legal 370 | Notices displayed by works containing it; or 371 | - c) Prohibiting misrepresentation of the origin of that material, 372 | or requiring that modified versions of such material be marked in 373 | reasonable ways as different from the original version; or 374 | - d) Limiting the use for publicity purposes of names of licensors 375 | or authors of the material; or 376 | - e) Declining to grant rights under trademark law for use of some 377 | trade names, trademarks, or service marks; or 378 | - f) Requiring indemnification of licensors and authors of that 379 | material by anyone who conveys the material (or modified versions 380 | of it) with contractual assumptions of liability to the recipient, 381 | for any liability that these contractual assumptions directly 382 | impose on those licensors and authors. 383 | 384 | All other non-permissive additional terms are considered "further 385 | restrictions" within the meaning of section 10. If the Program as you 386 | received it, or any part of it, contains a notice stating that it is 387 | governed by this License along with a term that is a further 388 | restriction, you may remove that term. If a license document contains 389 | a further restriction but permits relicensing or conveying under this 390 | License, you may add to a covered work material governed by the terms 391 | of that license document, provided that the further restriction does 392 | not survive such relicensing or conveying. 393 | 394 | If you add terms to a covered work in accord with this section, you 395 | must place, in the relevant source files, a statement of the 396 | additional terms that apply to those files, or a notice indicating 397 | where to find the applicable terms. 398 | 399 | Additional terms, permissive or non-permissive, may be stated in the 400 | form of a separately written license, or stated as exceptions; the 401 | above requirements apply either way. 402 | 403 | #### 8. Termination. 404 | 405 | You may not propagate or modify a covered work except as expressly 406 | provided under this License. Any attempt otherwise to propagate or 407 | modify it is void, and will automatically terminate your rights under 408 | this License (including any patent licenses granted under the third 409 | paragraph of section 11). 410 | 411 | However, if you cease all violation of this License, then your license 412 | from a particular copyright holder is reinstated (a) provisionally, 413 | unless and until the copyright holder explicitly and finally 414 | terminates your license, and (b) permanently, if the copyright holder 415 | fails to notify you of the violation by some reasonable means prior to 416 | 60 days after the cessation. 417 | 418 | Moreover, your license from a particular copyright holder is 419 | reinstated permanently if the copyright holder notifies you of the 420 | violation by some reasonable means, this is the first time you have 421 | received notice of violation of this License (for any work) from that 422 | copyright holder, and you cure the violation prior to 30 days after 423 | your receipt of the notice. 424 | 425 | Termination of your rights under this section does not terminate the 426 | licenses of parties who have received copies or rights from you under 427 | this License. If your rights have been terminated and not permanently 428 | reinstated, you do not qualify to receive new licenses for the same 429 | material under section 10. 430 | 431 | #### 9. Acceptance Not Required for Having Copies. 432 | 433 | You are not required to accept this License in order to receive or run 434 | a copy of the Program. Ancillary propagation of a covered work 435 | occurring solely as a consequence of using peer-to-peer transmission 436 | to receive a copy likewise does not require acceptance. However, 437 | nothing other than this License grants you permission to propagate or 438 | modify any covered work. These actions infringe copyright if you do 439 | not accept this License. Therefore, by modifying or propagating a 440 | covered work, you indicate your acceptance of this License to do so. 441 | 442 | #### 10. Automatic Licensing of Downstream Recipients. 443 | 444 | Each time you convey a covered work, the recipient automatically 445 | receives a license from the original licensors, to run, modify and 446 | propagate that work, subject to this License. You are not responsible 447 | for enforcing compliance by third parties with this License. 448 | 449 | An "entity transaction" is a transaction transferring control of an 450 | organization, or substantially all assets of one, or subdividing an 451 | organization, or merging organizations. If propagation of a covered 452 | work results from an entity transaction, each party to that 453 | transaction who receives a copy of the work also receives whatever 454 | licenses to the work the party's predecessor in interest had or could 455 | give under the previous paragraph, plus a right to possession of the 456 | Corresponding Source of the work from the predecessor in interest, if 457 | the predecessor has it or can get it with reasonable efforts. 458 | 459 | You may not impose any further restrictions on the exercise of the 460 | rights granted or affirmed under this License. For example, you may 461 | not impose a license fee, royalty, or other charge for exercise of 462 | rights granted under this License, and you may not initiate litigation 463 | (including a cross-claim or counterclaim in a lawsuit) alleging that 464 | any patent claim is infringed by making, using, selling, offering for 465 | sale, or importing the Program or any portion of it. 466 | 467 | #### 11. Patents. 468 | 469 | A "contributor" is a copyright holder who authorizes use under this 470 | License of the Program or a work on which the Program is based. The 471 | work thus licensed is called the contributor's "contributor version". 472 | 473 | A contributor's "essential patent claims" are all patent claims owned 474 | or controlled by the contributor, whether already acquired or 475 | hereafter acquired, that would be infringed by some manner, permitted 476 | by this License, of making, using, or selling its contributor version, 477 | but do not include claims that would be infringed only as a 478 | consequence of further modification of the contributor version. For 479 | purposes of this definition, "control" includes the right to grant 480 | patent sublicenses in a manner consistent with the requirements of 481 | this License. 482 | 483 | Each contributor grants you a non-exclusive, worldwide, royalty-free 484 | patent license under the contributor's essential patent claims, to 485 | make, use, sell, offer for sale, import and otherwise run, modify and 486 | propagate the contents of its contributor version. 487 | 488 | In the following three paragraphs, a "patent license" is any express 489 | agreement or commitment, however denominated, not to enforce a patent 490 | (such as an express permission to practice a patent or covenant not to 491 | sue for patent infringement). To "grant" such a patent license to a 492 | party means to make such an agreement or commitment not to enforce a 493 | patent against the party. 494 | 495 | If you convey a covered work, knowingly relying on a patent license, 496 | and the Corresponding Source of the work is not available for anyone 497 | to copy, free of charge and under the terms of this License, through a 498 | publicly available network server or other readily accessible means, 499 | then you must either (1) cause the Corresponding Source to be so 500 | available, or (2) arrange to deprive yourself of the benefit of the 501 | patent license for this particular work, or (3) arrange, in a manner 502 | consistent with the requirements of this License, to extend the patent 503 | license to downstream recipients. "Knowingly relying" means you have 504 | actual knowledge that, but for the patent license, your conveying the 505 | covered work in a country, or your recipient's use of the covered work 506 | in a country, would infringe one or more identifiable patents in that 507 | country that you have reason to believe are valid. 508 | 509 | If, pursuant to or in connection with a single transaction or 510 | arrangement, you convey, or propagate by procuring conveyance of, a 511 | covered work, and grant a patent license to some of the parties 512 | receiving the covered work authorizing them to use, propagate, modify 513 | or convey a specific copy of the covered work, then the patent license 514 | you grant is automatically extended to all recipients of the covered 515 | work and works based on it. 516 | 517 | A patent license is "discriminatory" if it does not include within the 518 | scope of its coverage, prohibits the exercise of, or is conditioned on 519 | the non-exercise of one or more of the rights that are specifically 520 | granted under this License. You may not convey a covered work if you 521 | are a party to an arrangement with a third party that is in the 522 | business of distributing software, under which you make payment to the 523 | third party based on the extent of your activity of conveying the 524 | work, and under which the third party grants, to any of the parties 525 | who would receive the covered work from you, a discriminatory patent 526 | license (a) in connection with copies of the covered work conveyed by 527 | you (or copies made from those copies), or (b) primarily for and in 528 | connection with specific products or compilations that contain the 529 | covered work, unless you entered into that arrangement, or that patent 530 | license was granted, prior to 28 March 2007. 531 | 532 | Nothing in this License shall be construed as excluding or limiting 533 | any implied license or other defenses to infringement that may 534 | otherwise be available to you under applicable patent law. 535 | 536 | #### 12. No Surrender of Others' Freedom. 537 | 538 | If conditions are imposed on you (whether by court order, agreement or 539 | otherwise) that contradict the conditions of this License, they do not 540 | excuse you from the conditions of this License. If you cannot convey a 541 | covered work so as to satisfy simultaneously your obligations under 542 | this License and any other pertinent obligations, then as a 543 | consequence you may not convey it at all. For example, if you agree to 544 | terms that obligate you to collect a royalty for further conveying 545 | from those to whom you convey the Program, the only way you could 546 | satisfy both those terms and this License would be to refrain entirely 547 | from conveying the Program. 548 | 549 | #### 13. Use with the GNU Affero General Public License. 550 | 551 | Notwithstanding any other provision of this License, you have 552 | permission to link or combine any covered work with a work licensed 553 | under version 3 of the GNU Affero General Public License into a single 554 | combined work, and to convey the resulting work. The terms of this 555 | License will continue to apply to the part which is the covered work, 556 | but the special requirements of the GNU Affero General Public License, 557 | section 13, concerning interaction through a network will apply to the 558 | combination as such. 559 | 560 | #### 14. Revised Versions of this License. 561 | 562 | The Free Software Foundation may publish revised and/or new versions 563 | of the GNU General Public License from time to time. Such new versions 564 | will be similar in spirit to the present version, but may differ in 565 | detail to address new problems or concerns. 566 | 567 | Each version is given a distinguishing version number. If the Program 568 | specifies that a certain numbered version of the GNU General Public 569 | License "or any later version" applies to it, you have the option of 570 | following the terms and conditions either of that numbered version or 571 | of any later version published by the Free Software Foundation. If the 572 | Program does not specify a version number of the GNU General Public 573 | License, you may choose any version ever published by the Free 574 | Software Foundation. 575 | 576 | If the Program specifies that a proxy can decide which future versions 577 | of the GNU General Public License can be used, that proxy's public 578 | statement of acceptance of a version permanently authorizes you to 579 | choose that version for the Program. 580 | 581 | Later license versions may give you additional or different 582 | permissions. However, no additional obligations are imposed on any 583 | author or copyright holder as a result of your choosing to follow a 584 | later version. 585 | 586 | #### 15. Disclaimer of Warranty. 587 | 588 | THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY 589 | APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT 590 | HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT 591 | WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT 592 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 593 | A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND 594 | PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE 595 | DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR 596 | CORRECTION. 597 | 598 | #### 16. Limitation of Liability. 599 | 600 | IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING 601 | WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR 602 | CONVEYS THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, 603 | INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES 604 | ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT 605 | NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR 606 | LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM 607 | TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER 608 | PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. 609 | 610 | #### 17. Interpretation of Sections 15 and 16. 611 | 612 | If the disclaimer of warranty and limitation of liability provided 613 | above cannot be given local legal effect according to their terms, 614 | reviewing courts shall apply local law that most closely approximates 615 | an absolute waiver of all civil liability in connection with the 616 | Program, unless a warranty or assumption of liability accompanies a 617 | copy of the Program in return for a fee. 618 | 619 | END OF TERMS AND CONDITIONS 620 | 621 | ### How to Apply These Terms to Your New Programs 622 | 623 | If you develop a new program, and you want it to be of the greatest 624 | possible use to the public, the best way to achieve this is to make it 625 | free software which everyone can redistribute and change under these 626 | terms. 627 | 628 | To do so, attach the following notices to the program. It is safest to 629 | attach them to the start of each source file to most effectively state 630 | the exclusion of warranty; and each file should have at least the 631 | "copyright" line and a pointer to where the full notice is found. 632 | 633 | 634 | Copyright (C) 635 | 636 | This program is free software: you can redistribute it and/or modify 637 | it under the terms of the GNU General Public License as published by 638 | the Free Software Foundation, either version 3 of the License, or 639 | (at your option) any later version. 640 | 641 | This program is distributed in the hope that it will be useful, 642 | but WITHOUT ANY WARRANTY; without even the implied warranty of 643 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 644 | GNU General Public License for more details. 645 | 646 | You should have received a copy of the GNU General Public License 647 | along with this program. If not, see . 648 | 649 | Also add information on how to contact you by electronic and paper 650 | mail. 651 | 652 | If the program does terminal interaction, make it output a short 653 | notice like this when it starts in an interactive mode: 654 | 655 | Copyright (C) 656 | This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. 657 | This is free software, and you are welcome to redistribute it 658 | under certain conditions; type `show c' for details. 659 | 660 | The hypothetical commands \`show w' and \`show c' should show the 661 | appropriate parts of the General Public License. Of course, your 662 | program's commands might be different; for a GUI interface, you would 663 | use an "about box". 664 | 665 | You should also get your employer (if you work as a programmer) or 666 | school, if any, to sign a "copyright disclaimer" for the program, if 667 | necessary. For more information on this, and how to apply and follow 668 | the GNU GPL, see . 669 | 670 | The GNU General Public License does not permit incorporating your 671 | program into proprietary programs. If your program is a subroutine 672 | library, you may consider it more useful to permit linking proprietary 673 | applications with the library. If this is what you want to do, use the 674 | GNU Lesser General Public License instead of this License. But first, 675 | please read . 676 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | PKGVERSION = $(shell git describe --always) 2 | 3 | build: 4 | dune build @install 5 | 6 | test: 7 | $(RM) -f $(wildcard _build/default/tests/*.pdf) 8 | dune runtest 9 | dune build @latex 10 | 11 | demo: 12 | dune build @demo --force 13 | 14 | install uninstall: 15 | dune $@ 16 | 17 | pin: 18 | opam pin add -k path curve-sampling.dev . 19 | unpin: 20 | opam pin remove curve-sampling 21 | 22 | doc: 23 | dune build @doc 24 | sed -e 's/%%VERSION%%/$(PKGVERSION)/' --in-place \ 25 | _build/default/_doc/_html/curve-sampling/Curve_sampling/index.html 26 | 27 | lint: 28 | opam lint curve-sampling.opam 29 | 30 | clean: 31 | dune clean 32 | 33 | .PHONY: build test demo install uninstall pin unpin doc lint clean 34 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ![Continuous Integration](https://github.com/Chris00/ocaml-curve-sampling/actions/workflows/main.yml/badge.svg) 2 | 3 | Curve Sampling 4 | ============== 5 | 6 | This module provide a collection of routines to perform adaptive 7 | sampling of parametric and implicit curves as well as manipulating 8 | those samplings. 9 | 10 | Install 11 | ------- 12 | 13 | The easier way to install this library is to use [opam][]: 14 | 15 | opam install curve-sampling 16 | 17 | If you prefer to compile by hand, install the dependencies listed in 18 | [curve-sampling.opam](curve-sampling.opam) and issue `dune build 19 | @install`. 20 | 21 | [opam]: https://opam.ocaml.org/ 22 | 23 | 24 | Documentation 25 | ------------- 26 | 27 | The documentation is available in 28 | [curve_sampling.mli](src/curve_sampling.mli) or 29 | [online](https://chris00.github.io/ocaml-curve-sampling/doc/curve-sampling/Curve_sampling/). 30 | 31 | Example 32 | ------- 33 | 34 | Here is a graph of the function x ↦ x sin(1/x) produced with only 227 35 | evaluations of the function. 36 | ![x sin(1/x)](https://user-images.githubusercontent.com/1255665/70428344-b302f500-1a76-11ea-9b9e-150ad4794ed6.png) 37 | -------------------------------------------------------------------------------- /curve-sampling.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "Christophe Troestler " 3 | authors: [ "Christophe Troestler " ] 4 | license: "GPL-3.0+" 5 | homepage: "https://github.com/Chris00/ocaml-curve-sampling" 6 | dev-repo: "git+https://github.com/Chris00/ocaml-curve-sampling.git" 7 | bug-reports: "https://github.com/Chris00/ocaml-curve-sampling/issues" 8 | doc: "https://Chris00.github.io/ocaml-curve-sampling/doc" 9 | build: [ 10 | ["dune" "subst"] {dev} 11 | ["dune" "build" "-p" name "-j" jobs] 12 | ["dune" "runtest" "-p" name "-j" jobs] {with-test & os = "linux"} 13 | ] 14 | depends: [ 15 | "ocaml" {>= "4.02.3"} 16 | "gg" {>= "0.9.3"} 17 | "dune" {>= "1.3"} 18 | "cppo" {build & >= "1.3.0"} 19 | "conf-gnuplot" {with-test & os = "linux"} 20 | "gsl" {with-test & os = "linux"} 21 | ] 22 | synopsis: "Sampling of parametric and implicit curves" 23 | description: """ 24 | Adaptive sampling of parametric and implicit curves (the latter is WIP).""" 25 | -------------------------------------------------------------------------------- /demo/dune: -------------------------------------------------------------------------------- 1 | (executables 2 | (names graphs) 3 | (libraries curve_sampling)) 4 | 5 | (rule 6 | (targets graphs.gp graph1.dat graph2.dat) 7 | (action (run %{exe:graphs.exe}))) 8 | 9 | (alias 10 | (name demo) 11 | (deps graphs.gp) 12 | (action (run gnuplot %{deps}))) 13 | 14 | -------------------------------------------------------------------------------- /demo/graphs.ml: -------------------------------------------------------------------------------- 1 | open Printf 2 | 3 | let () = 4 | let fh = open_out "graphs.gp" in 5 | fprintf fh "set terminal pngcairo\n\ 6 | set grid\n"; 7 | let n = ref 0 in 8 | let save t ~title = 9 | incr n; 10 | let fname = sprintf "graph%d.dat" !n in 11 | Curve_sampling.to_file t fname; 12 | fprintf fh "set output \"graph%d.png\"\n\ 13 | plot %S with l lt 1 lw 2 title %S\n" !n fname title; 14 | fprintf fh "set output \"graph%d_p.png\"\n\ 15 | plot %S with l lt 5 lw 2 title %S, \ 16 | %S with p lt 1 pt 5 ps 0.2 title \"points\"\n" 17 | !n fname title fname 18 | in 19 | 20 | let f x = x *. sin(1. /. x) in 21 | let t = Curve_sampling.fn f (-0.4) 0.4 ~n:227 in 22 | save t ~title:"x sin(1/x)"; 23 | let t = Curve_sampling.fn f (-0.4) 0.4 ~n:391 in 24 | save t ~title:"x sin(1/x)"; 25 | 26 | let t = Curve_sampling.fn (fun x -> sin(1. /. x)) (-0.4) 0.4 ~n:391 in 27 | save t ~title:"sin(1/x)"; 28 | 29 | close_out fh 30 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 1.1) 2 | 3 | (name curve-sampling) 4 | -------------------------------------------------------------------------------- /src/PQ.ml: -------------------------------------------------------------------------------- 1 | (* File: curve_sampling_pq.ml 2 | 3 | Copyright (C) 2016- 4 | 5 | Christophe Troestler 6 | WWW: http://math.umons.ac.be/an/software/ 7 | 8 | This library is free software; you can redistribute it and/or modify 9 | it under the terms of the GNU Lesser General Public License version 3 or 10 | later as published by the Free Software Foundation, with the special 11 | exception on linking described in the file LICENSE. 12 | 13 | This library is distributed in the hope that it will be useful, but 14 | WITHOUT ANY WARRANTY; without even the implied warranty of 15 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the file 16 | LICENSE for more details. *) 17 | 18 | (* Maximum priority queue. Implemented as a Pairing heap 19 | (http://en.wikipedia.org/wiki/Pairing_heap) following the paper: 20 | 21 | Fredman, Michael L.; Sedgewick, Robert; Sleator, Daniel D.; Tarjan, 22 | Robert E. (1986). "The pairing heap: a new form of self-adjusting 23 | heap" (PDF). Algorithmica. 1 (1): 111–129. doi:10.1007/BF01840439. *) 24 | 25 | let is_nan x = (x: float) <> x [@@inline] 26 | 27 | type 'a node = { 28 | mutable priority: float; 29 | data: 'a; 30 | mutable child: 'a node; (* points to oneself if no child *) 31 | mutable sibling: 'a node; (* next older sibling (or parent if last) *) 32 | mutable parent: 'a node; (* points to oneself if root node *) 33 | } 34 | (* Remark: because of mutability, a node can only belong to a single tree. *) 35 | 36 | let has_children n = n.child != n 37 | let not_last_sibling n = n.sibling != n.parent 38 | let is_root n = n.parent == n 39 | 40 | (* Since we will need to update the nodes, we need the tree to be 41 | mutable in case the root changes. *) 42 | type 'a t = 'a node option ref 43 | 44 | 45 | let make() = ref None 46 | 47 | let is_empty q = (!q = None) [@@inline] 48 | 49 | let max q = match !q with 50 | | None -> failwith "Curve_Sampling.PQ.max: empty" 51 | | Some node -> node.data 52 | 53 | let max_priority q = match !q with 54 | | None -> neg_infinity 55 | | Some node -> node.priority 56 | 57 | (* Will modify [n1] and [n2]. The one that is returned keeps its 58 | parent and siblings. *) 59 | let merge_pair n1 n2 = 60 | if n1.priority > n2.priority then ( 61 | let c1 = n1.child in 62 | n1.child <- n2; 63 | (* Because of the convention that the sibling = parent if last, we 64 | do not have to make a special case for the 1st child. *) 65 | n2.sibling <- c1; n2.parent <- n1; 66 | n1) 67 | else ( 68 | let c2 = n2.child in 69 | n2.child <- n1; 70 | n1.sibling <- c2; n1.parent <- n2; 71 | n2) 72 | [@@inline] 73 | 74 | (* Beware that [n] may become the new root and that then its parent 75 | and sibling need to have been set correctly. *) 76 | let add_node q n = 77 | q := Some(match !q with 78 | | None -> n 79 | | Some root -> merge_pair n root) 80 | 81 | let add q p x = 82 | if is_nan p then 83 | invalid_arg "Curve_Sampling.PQ.add: NaN priority not allowed"; 84 | let rec n = { priority = p; data = x; 85 | child = n; sibling = n; parent = n } in 86 | (* Whichever [n] or the root of [q] becomes the new root, parent and 87 | sibling are fine. *) 88 | add_node q n 89 | 90 | type 'a witness = { 91 | queue: 'a t; (* To make sure the witness is for the right queue *) 92 | node: 'a node; 93 | } 94 | 95 | let witness_add q p x = 96 | if is_nan p then 97 | invalid_arg "Curve_Sampling.PQ.witness_add: NaN priority not allowed"; 98 | let rec n = { priority = p; data = x; 99 | child = n; sibling = n; parent = n } in 100 | add_node q n; 101 | { queue = q; node = n } 102 | 103 | let priority w = w.node.priority 104 | 105 | (* All the parents of [n0] and its siblings are replaced except for 106 | the node that is returned (which keeps the values it had). *) 107 | let rec merge_pairs n0 = 108 | if not_last_sibling n0 then ( 109 | let n1 = n0.sibling in 110 | if not_last_sibling n1 then 111 | merge_pair (merge_pair n0 n1) (merge_pairs n1.sibling) 112 | else 113 | merge_pair n0 n1 114 | ) 115 | else n0 116 | 117 | let delete_max q = match !q with 118 | | None -> failwith "Curve_Sampling.PQ.delete_max: empty" 119 | | Some root -> 120 | (if has_children root then 121 | let root' = merge_pairs root.child in 122 | (* Update the parent of the selected child (important to 123 | release the reference to [root]). *) 124 | root'.parent <- root'; 125 | root'.sibling <- root'; 126 | q := Some root' 127 | else q := None); 128 | root.data 129 | 130 | (* REMARK: To be removed a node must become root. Thus the state of 131 | removed nodes is necessarily root and using [increase_priority] on 132 | a removed node will not change the queue it used to belong to. *) 133 | let increase_priority p witness = 134 | if is_nan p then 135 | invalid_arg "Curve_Sampling.PQ.increase_priority: NaN priority not allowed"; 136 | let n = witness.node in 137 | if n.priority < p then 138 | if is_root n then 139 | n.priority <- p 140 | else ( 141 | (* Cut [n] (and its children) from the tree and re-insert it 142 | with the new priority. *) 143 | let parent = n.parent in 144 | if parent.child == n then 145 | parent.child <- n.sibling (* fine if it is the only child. *) 146 | else ( 147 | let n_prev = ref parent.child (* first child *) in 148 | while !n_prev.sibling != n do n_prev := !n_prev.sibling done; 149 | !n_prev.sibling <- n.sibling; (* OK even if [n] is last *) 150 | ); 151 | n.priority <- p; 152 | n.sibling <- n; 153 | n.parent <- n; 154 | add_node witness.queue n; 155 | ) 156 | 157 | let rec iter_nodes n f = 158 | f n.data; 159 | if has_children n then iter_nodes n.child f; 160 | if not_last_sibling n then iter_nodes n.sibling f 161 | 162 | let iter q ~f = match !q with 163 | | None -> () 164 | | Some root -> iter_nodes root f 165 | 166 | let rec iteri_nodes n f = 167 | f n.priority n.data; 168 | if has_children n then iteri_nodes n.child f; 169 | if not_last_sibling n then iteri_nodes n.sibling f 170 | 171 | let iteri q ~f = match !q with 172 | | None -> () 173 | | Some root -> iteri_nodes root f 174 | 175 | 176 | let rec fold_nodes n init f = 177 | let init = f init n.data in 178 | let init = if has_children n then fold_nodes n.child init f 179 | else init in 180 | if not_last_sibling n then fold_nodes n.sibling init f 181 | else init 182 | 183 | let fold q ~init ~f = match !q with 184 | | None -> init 185 | | Some root -> fold_nodes root init f 186 | 187 | let rec foldi_nodes n init f = 188 | let init = f init n.priority n.data in 189 | let init = if has_children n then foldi_nodes n.child init f 190 | else init in 191 | if not_last_sibling n then foldi_nodes n.sibling init f 192 | else init 193 | 194 | let foldi q ~init ~f = match !q with 195 | | None -> init 196 | | Some root -> foldi_nodes root init f 197 | 198 | (* Since the nodes are mutable, we need to duplicate them. *) 199 | let rec map_nodes n ~new_parent f = 200 | let rec n' = { priority = n.priority; data = f n.data; 201 | child = n'; sibling = new_parent; parent = new_parent } in 202 | if has_children n then 203 | n'.child <- map_nodes n.child ~new_parent:n' f; 204 | if not_last_sibling n then 205 | n'.sibling <- map_nodes n.sibling ~new_parent f; 206 | n' 207 | 208 | let map q ~f = match !q with 209 | | None -> ref None 210 | | Some root -> 211 | let rec root' = { priority = root.priority; data = f root.data; 212 | child = root'; sibling = root'; parent = root' } in 213 | if has_children root then 214 | root'.child <- map_nodes root.child ~new_parent:root' f; 215 | ref(Some root') 216 | 217 | 218 | let rec filter_map_nodes n ~new_parent f = 219 | match f n.data with 220 | | Some y -> 221 | let rec n' = { priority = n.priority; data = y; 222 | child = n'; sibling = n'; parent = n' } in 223 | (* If [new_parent] is not known, set it to the node itself. 224 | Either the node will (eventually) be merged with [merge_pairs] 225 | or it will be returned in which case it will be the new root. *) 226 | (match new_parent with 227 | | Some p -> n'.sibling <- p; n'.parent <- p 228 | | None -> ()); 229 | if has_children n then ( 230 | match filter_map_nodes n.child ~new_parent:(Some n') f with 231 | | Some child -> n'.child <- child 232 | | None -> () (* all children removed *) 233 | ); 234 | if not_last_sibling n then ( 235 | match filter_map_nodes n.sibling ~new_parent f with 236 | | Some sibling -> n'.sibling <- sibling 237 | | None -> () 238 | ); 239 | Some n' 240 | | None -> 241 | (* Remove the node. Similar to [increase_priority] except that we 242 | do not know the new root yet so we will only move the children 243 | one level up. *) 244 | let child = 245 | if has_children n then 246 | (match filter_map_nodes n.child ~new_parent f with 247 | | Some n -> 248 | (* We merge all updated children [n] to make sure the 249 | heap property is preserved. *) 250 | let n = merge_pairs n in 251 | (* [n.parent] already set by above rec call *) 252 | n.sibling <- n; (* in case it becomes root *) 253 | Some n 254 | | None -> None) 255 | else None in 256 | let sibling = if not_last_sibling n then 257 | filter_map_nodes n.sibling ~new_parent f 258 | else None in 259 | match child, sibling with 260 | | Some n1, Some n2 -> n1.sibling <- n2; 261 | Some n1 262 | | (Some _ as n), None | None, (Some _ as n) -> n 263 | | None, None -> None 264 | 265 | let filter_map q ~f = match !q with 266 | | None -> ref None 267 | | Some root -> ref(filter_map_nodes root ~new_parent:None f) 268 | -------------------------------------------------------------------------------- /src/PQ.mli: -------------------------------------------------------------------------------- 1 | (* File: curve_sampling_pq.mli 2 | 3 | Copyright (C) 2016- 4 | 5 | Christophe Troestler 6 | WWW: http://math.umons.ac.be/an/software/ 7 | 8 | This library is free software; you can redistribute it and/or modify 9 | it under the terms of the GNU Lesser General Public License version 3 or 10 | later as published by the Free Software Foundation, with the special 11 | exception on linking described in the file LICENSE. 12 | 13 | This library is distributed in the hope that it will be useful, but 14 | WITHOUT ANY WARRANTY; without even the implied warranty of 15 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the file 16 | LICENSE for more details. *) 17 | 18 | type 'a t 19 | (** Mutable maximum priority queue, with float priority. *) 20 | 21 | type 'a witness 22 | (** A value witness that enables to increase its priority or remove it 23 | from the priority queue. *) 24 | 25 | val make : unit -> 'a t 26 | (** [make()] returns an empty priority queue. *) 27 | 28 | val is_empty : 'a t -> bool 29 | (** [is_empty q] tells whether the queue [q] is empty. *) 30 | 31 | val add : 'a t -> float -> 'a -> unit 32 | (** [add q p x] add [x] with priority [p] to [q]. 33 | @raise Invalid_argument if [p] is NaN. *) 34 | 35 | val witness_add : 'a t -> float -> 'a -> 'a witness 36 | (** [witness_add q p x] does the same as {!add} and in addition return 37 | a witness for [x]. *) 38 | 39 | val max : 'a t -> 'a 40 | (** [max q] returns an element of [q] with maximum priority. 41 | @raise Failure if the queue is empty. *) 42 | 43 | val max_priority : 'a t -> float 44 | (** [max_priority q] returns the maximum priority of elements in [q] 45 | or [neg_infinity] if [q] is empty. *) 46 | 47 | val delete_max : 'a t -> 'a 48 | (** [delete_max q] delete an element with maximum priority from [q] 49 | and return it. 50 | 51 | @raise Failure if the queue is empty. *) 52 | 53 | val priority : 'a witness -> float 54 | (** [priority w] returns the priority of the element witnessed by [w]. *) 55 | 56 | val increase_priority : float -> 'a witness -> unit 57 | (** [increase_priority p w] set the priority of the value pointed by 58 | the witness [w] to [p] (in the queue in which the value is). If 59 | the new priority is lower than the previously given one, this 60 | function does nothing. *) 61 | 62 | val fold : 'a t -> init:'b -> f:('b -> 'a -> 'b) -> 'b 63 | (** [fold q init f] folds the function [f] on all elements present in 64 | the queue [q]. The order in which elements are passed is 65 | unspecified. *) 66 | 67 | val foldi : 'a t -> init:'b -> f:('b -> float -> 'a -> 'b) -> 'b 68 | (** [foldi q init f] same as {!fold} but [f] also receive the priority. *) 69 | 70 | val iter : 'a t -> f:('a -> unit) -> unit 71 | (** [iter q f] iterates the function [f] on all elements present in 72 | the queue [q] (which is unchanged). The order in which elements 73 | are passed is unspecified. *) 74 | 75 | val iteri : 'a t -> f:(float -> 'a -> unit) -> unit 76 | (** [iteri q f] same as {!iter} but [f] also receive the priority. *) 77 | 78 | val map : 'a t -> f:('a -> 'b) -> 'b t 79 | (** [map q f] return a new priority queue with the same priority 80 | structure than [q] but with [f x] instead of each data value [x]. *) 81 | 82 | val filter_map : 'a t -> f:('a -> 'b option) -> 'b t 83 | (** [filter_map q f] Same as [map] be remove the values for which [f] 84 | returns [None]. *) 85 | 86 | ;; 87 | -------------------------------------------------------------------------------- /src/curve_sampling.ml: -------------------------------------------------------------------------------- 1 | open Printf 2 | open Gg 3 | module Rnd = Random.State 4 | 5 | let rnd = Rnd.make_self_init() 6 | 7 | let is_finite (x: float) = x -. x = 0. [@@inline] 8 | 9 | type point = { 10 | t: float; (* parameter, MUST be finite *) 11 | x: float; (* valid ⇔ is_finite x (and thus is_finite y) *) 12 | y: float; 13 | mutable cost: float; (* cache the cost for faster updates of 14 | segments. See module {!Cost}. *) 15 | } (* pure float record ⇒ optimized *) 16 | 17 | let dummy_point = { t = nan; x = nan; y = nan; cost = nan } 18 | 19 | let is_valid p = is_finite p.x [@@inline] 20 | 21 | let point ~t ~x ~y ~cost = 22 | { t; x = (if is_finite y then x else nan); y; cost } [@@inline] 23 | 24 | let point0 ~t ~x ~y = 25 | { t; x = (if is_finite y then x else nan); y; cost = 0. } [@@inline] 26 | 27 | (* WARNING: Because of mutability, segments may only belong to at most 28 | one sampling. *) 29 | type segment = { 30 | (* At least one of [p0] and [p1] must be valid. *) 31 | p0: point; 32 | p1: point; 33 | (* Segments are ordered by increasing values of [t]. There may be 34 | jumps however in [t] values. *) 35 | mutable prev: segment; (* previous segment in curve; oneself if first. *) 36 | mutable next: segment; (* next segment in curve; oneself if last. *) 37 | (* The segments are all linked together in the direction of the 38 | parametrisation of the path, even across path "cuts". A "cut" 39 | may be expressed by an invalid point (a point outside the 40 | domain, the boundary of which needs to be refined) or by the 41 | fact that [p1 != next.p0] (in which case, the parameter [t] may 42 | be considered starting anew). *) 43 | 44 | mutable witness: segment PQ.witness option; 45 | } 46 | 47 | let is_first s = s.prev == s [@@inline] 48 | let is_last s = s.next == s [@@inline] 49 | 50 | let rec dummy_seg = { 51 | p0 = dummy_point; p1 = dummy_point; 52 | prev = dummy_seg; next = dummy_seg; witness = None } 53 | 54 | (* Segment with [.prev] and [.next] being itself. *) 55 | let segment ~p0 ~p1 = 56 | (let rec s = { p0; p1; prev = s; next = s; 57 | witness = None } in 58 | s) [@@inline] 59 | 60 | (* The phantom type variable will say whether the sampling correspond 61 | to a function — and thus can be refined — or not. *) 62 | type 'a t = { 63 | seg: segment PQ.t; (* DISJOINT segments (except for endpoints). *) 64 | (* If the queue is empty but not the segment list, costs need 65 | updating. When the queue is non-empty, all segments MUST have 66 | a witness. *) 67 | mutable first: segment; (* or dummy if [seg] is empty. *) 68 | mutable last: segment; (* or dummy if [seg] is empty. *) 69 | vp: Box2.t; (* viewport = zone of interest *) 70 | } 71 | 72 | let is_empty t = t.first == dummy_seg [@@inline] 73 | 74 | let make_empty () = { 75 | seg = PQ.make(); first = dummy_seg; last = dummy_seg; 76 | vp = Box2.unit } 77 | 78 | let len_txy (t: [`Fn] t) = 79 | (t.last.p1.t -. t.first.p0.t, Box2.w t.vp, Box2.h t.vp) [@@inline] 80 | 81 | (** A "connected" sub-path means a sequence of segments such that, 82 | for all segments [s] but the last one, [s.p1 == s.next.p0] and all 83 | these points are valid ([p0] of the first segment and [p1] of the 84 | last segment may be invalid). *) 85 | (* [last_is_cut] is true if the last operation was a [cut]. [cut] is 86 | applied for any path interruption. *) 87 | let rec fold_points_incr_segments ~prev_p ~last_is_cut f ~cut acc seg = 88 | let p0 = seg.p0 and p1 = seg.p1 in 89 | let acc = 90 | if p0 == prev_p then (* p0 already treated (usual case) *) 91 | if is_valid p1 then f acc p1 92 | else if is_last seg then acc else cut acc (* p0 valid *) 93 | else if is_valid p0 then 94 | let acc = f (if last_is_cut then acc else cut acc) p0 in 95 | if is_valid p1 then f acc p1 96 | else if is_last seg then acc else cut acc 97 | else (* not(is_valid p0), thus cut and p1 valid *) 98 | f (if last_is_cut then acc else cut acc) p1 in 99 | if is_last seg then acc 100 | else fold_points_incr_segments ~prev_p:p1 ~last_is_cut:(not(is_valid p1)) 101 | f ~cut acc seg.next 102 | 103 | (** [fold t ~init f] fold [f] once on each valid point. The points 104 | are passed in the order of the curve. *) 105 | let fold_points t ~init ~cut f = 106 | if is_empty t then init 107 | else (* [last_is_cut] is true at first because we do not want to 108 | introduce a [cut] at the beginning of the curve. *) 109 | fold_points_incr_segments ~prev_p:dummy_point ~last_is_cut:true 110 | f ~cut init t.first 111 | 112 | let rec fold_points_decr_segments ~prev_p ~last_is_cut f ~cut acc seg = 113 | let p0 = seg.p0 and p1 = seg.p1 in 114 | let acc = 115 | if p1 == prev_p then 116 | if is_valid p0 then f acc p0 117 | else if is_first seg then acc else cut acc (* No cut at 1st place *) 118 | else if is_valid p1 then 119 | let acc = f (if last_is_cut then acc else cut acc) p1 in 120 | if is_valid p0 then f acc p0 121 | else if is_first seg then acc else cut acc 122 | else (* not(is_valid p1), thus cut and p0 valid *) 123 | f (if last_is_cut then acc else cut acc) p0 in 124 | if is_first seg then acc 125 | else fold_points_decr_segments ~prev_p:p0 ~last_is_cut:(not(is_valid p0)) 126 | f ~cut acc seg.prev 127 | 128 | (** Same as [fold] but the points are passed in the opposite order of 129 | the curve. *) 130 | let fold_points_decr t ~init ~cut f = 131 | if is_empty t then init 132 | else fold_points_decr_segments ~prev_p:dummy_point ~last_is_cut:true 133 | f ~cut init t.last 134 | 135 | let bounding_box t = 136 | fold_points t ~init:Gg.Box2.empty ~cut:(fun x -> x) 137 | (fun b p -> if is_finite p.x then Gg.Box2.add_pt b (Gg.P2.v p.x p.y) 138 | else b) 139 | 140 | let rec map_segments ~prev_p ~prev_fp ~prev_s s f = 141 | let p0 = if s.p0 == prev_p then prev_fp else f s.p0 in 142 | let p1 = f s.p1 in 143 | let s' = segment ~p0 ~p1 in 144 | s'.prev <- prev_s; 145 | prev_s.next <- s'; 146 | if is_last s then (s'.next <- s'; s') 147 | else map_segments ~prev_p:s.p1 ~prev_fp:p1 ~prev_s:s' s.next f 148 | 149 | (** Create a new sampling by applying [f] to all points. *) 150 | let map t ~f = 151 | if is_empty t then make_empty() 152 | else 153 | let p0 = f t.first.p0 in 154 | let p1 = f t.first.p1 in 155 | let first' = segment ~p0 ~p1 in 156 | if is_last t.first then ( (* single segment *) 157 | first'.next <- first'; 158 | { seg = PQ.make(); (* costs need recomputing *) 159 | first = first'; last = first'; vp = Box2.unit } 160 | ) 161 | else 162 | let last' = map_segments ~prev_p:t.first.p1 ~prev_fp:p0 ~prev_s:first' 163 | t.first.next f in 164 | { seg = PQ.make(); 165 | first = first'; last = last'; vp = t.vp } 166 | 167 | 168 | (** Save *) 169 | 170 | let to_channel t fh = 171 | fold_points t ~init:() 172 | (fun () p -> fprintf fh "%e\t%e\n" p.x p.y) 173 | ~cut:(fun () -> output_char fh '\n') 174 | 175 | let to_file t fname = 176 | let fh = open_out fname in 177 | to_channel t fh; 178 | close_out fh 179 | 180 | let to_latex_channel_line t ~pgf_max_nodes fh = 181 | (* The accumulator says whether a new sub-path has to be started. *) 182 | let n = ref 0 in 183 | fold_points t ~init:true 184 | (fun new_path p -> 185 | if new_path then 186 | fprintf fh "\\pgfpathmoveto{\\pgfpointxy{%.16f}{%.16f}}\n" p.x p.y 187 | else if !n >= pgf_max_nodes then ( 188 | fprintf fh "\\pgfpathlineto{\\pgfpointxy{%.16f}{%.16f}}\n\ 189 | \\pgfusepath{stroke}\n\ 190 | \\pgfpathmoveto{\\pgfpointxy{%.16f}{%.16f}}\n" 191 | p.x p.y p.x p.y; 192 | n := 0) 193 | else 194 | fprintf fh "\\pgfpathlineto{\\pgfpointxy{%.16f}{%.16f}}\n" p.x p.y; 195 | false) 196 | ~cut:(fun _ -> fprintf fh "\\pgfusepath{stroke}\n"; 197 | n := 0; 198 | true) 199 | 200 | let to_latex_channel_arrow t ~pgf_max_nodes ~arrow ~arrow_pos fh = 201 | let pos = if arrow_pos > 1. then 1. 202 | else if arrow_pos < 0. then 0. 203 | else arrow_pos in 204 | (* Compute the length of all sub-paths *) 205 | let prev_x = ref nan in 206 | let prev_y = ref nan in 207 | let len, lens = 208 | fold_points t ~init:(0., []) 209 | (fun (cur_len, lens) p -> 210 | let l = if is_finite !prev_x then 211 | hypot (p.x -. !prev_x) (p.y -. !prev_y) 212 | else 0. (* no previous segment *) in 213 | prev_x := p.x; 214 | prev_y := p.y; 215 | (cur_len +. l, lens)) 216 | ~cut:(fun (len, lens) -> prev_x := nan; 217 | prev_y := nan; 218 | (0., (pos *. len) :: lens)) in 219 | match List.rev ((pos *. len) :: lens) with 220 | | [] -> () 221 | | cur_len :: lens -> 222 | let prev_x = ref nan in 223 | let prev_y = ref nan in 224 | let n = ref 0 in 225 | let len = ref cur_len in 226 | let lens = ref lens in 227 | let _ = 228 | fold_points t ~init:true 229 | (fun new_path p -> 230 | incr n; 231 | if new_path then 232 | fprintf fh "\\pgfpathmoveto{\\pgfpointxy{%.16f}{%.16f}}\n" 233 | p.x p.y 234 | else ( 235 | let dx = p.x -. !prev_x and dy = p.y -. !prev_y in 236 | let l = if is_finite !prev_x then hypot dx dy else 0. in 237 | if !len <= l then ( 238 | fprintf fh "\\pgfusepath{stroke}\n"; 239 | (* Drawing a long path with an arrow specified is 240 | extremely expensive. Just draw the current segment. *) 241 | let pct = !len /. l in 242 | if pct < 1e-14 then ( 243 | fprintf fh "\\pgfsetarrowsstart{%s}\n\ 244 | \\pgfpathmoveto{\\pgfpointxy{%.16f}{%.16f}}\n\ 245 | \\pgfpathlineto{\\pgfpointxy{%.16f}{%.16f}}\n\ 246 | \\pgfusepath{stroke}\n\ 247 | \\pgfsetarrowsstart{}\n\ 248 | \\pgfpathmoveto{\\pgfpointxy{%.16f}{%.16f}}\n" 249 | arrow !prev_x !prev_y p.x p.y p.x p.y; 250 | n := 1; 251 | ) 252 | else ( 253 | let xm = !prev_x +. pct *. dx in 254 | let ym = !prev_y +. pct *. dy in 255 | fprintf fh "\\pgfsetarrowsend{%s}\n\ 256 | \\pgfpathmoveto{\\pgfpointxy{%.16f}{%.16f}}\n\ 257 | \\pgfpathlineto{\\pgfpointxy{%.16f}{%.16f}}\n\ 258 | \\pgfusepath{stroke}\n\ 259 | \\pgfsetarrowsend{}\n\ 260 | \\pgfpathmoveto{\\pgfpointxy{%.16f}{%.16f}}\n\ 261 | \\pgfpathlineto{\\pgfpointxy{%.16f}{%.16f}}\n" 262 | arrow !prev_x !prev_y xm ym xm ym p.x p.y; 263 | n := 2; 264 | ); 265 | len := infinity; (* draw no more arrow *) 266 | ) 267 | else if !n >= pgf_max_nodes then ( 268 | fprintf fh "\\pgfpathlineto{\\pgfpointxy{%.16f}{%.16f}}\n\ 269 | \\pgfusepath{stroke}\n\ 270 | \\pgfpathmoveto{\\pgfpointxy{%.16f}{%.16f}}\n" 271 | p.x p.y p.x p.y; 272 | n := 0) 273 | else 274 | fprintf fh "\\pgfpathlineto{\\pgfpointxy{%.16f}{%.16f}}\n" 275 | p.x p.y; 276 | len := !len -. l; 277 | ); 278 | prev_x := p.x; 279 | prev_y := p.y; 280 | false) 281 | ~cut:(fun _ -> 282 | fprintf fh "\\pgfusepath{stroke}\n"; 283 | (match !lens with l :: ls -> len := l; lens := ls 284 | | [] -> assert false); 285 | true) in 286 | () 287 | 288 | let to_latex_channel t ?n:(pgf_max_nodes = 20_000) ?arrow ?arrow_pos ?color fh = 289 | output_string fh "% Written by OCaml Curve_sampling (version %%VERSION%%)\n"; 290 | output_string fh "\\begin{pgfscope}\n"; 291 | (match color with 292 | | Some c -> 293 | fprintf fh "\\definecolor{OCamlCurveSamplingColor}{rgb}{%f,%f,%f}\n\ 294 | \\pgfsetstrokecolor{OCamlCurveSamplingColor}\n" 295 | (Gg.Color.r c) (Gg.Color.g c) (Gg.Color.b c); 296 | | None -> ()); 297 | (match arrow, arrow_pos with 298 | | None, None -> ignore(to_latex_channel_line t ~pgf_max_nodes fh) 299 | | Some arrow, None -> 300 | to_latex_channel_arrow t ~pgf_max_nodes ~arrow ~arrow_pos:0.5 fh 301 | | None, Some arrow_pos -> 302 | to_latex_channel_arrow t ~pgf_max_nodes ~arrow:">" ~arrow_pos fh 303 | | Some arrow, Some arrow_pos -> 304 | to_latex_channel_arrow t ~pgf_max_nodes ~arrow ~arrow_pos fh); 305 | output_string fh "\\pgfusepath{stroke}\n\\end{pgfscope}\n" 306 | 307 | let to_latex t ?n ?arrow ?arrow_pos ?color fname = 308 | let fh = open_out fname in 309 | to_latex_channel t ?n ?arrow ?arrow_pos ?color fh; 310 | close_out fh 311 | 312 | let to_list t = 313 | let path, seg = fold_points_decr t ~init:([], []) 314 | (fun (path, seg) p -> (path, (p.x, p.y) :: seg)) 315 | ~cut:(fun (path, seg) -> (seg :: path, [])) in 316 | if seg <> [] then seg :: path else path 317 | 318 | (** Transform *) 319 | 320 | let tr m t = 321 | map t ~f:(fun p -> let p' = P2.tr m (P2.v p.x p.y) in 322 | point ~t:p.t ~x:(P2.x p') ~y:(P2.y p') ~cost:nan) 323 | 324 | (* Constructing samplings 325 | ***********************************************************************) 326 | 327 | (* Compute a sampling from a sequence of points. No costs are computed. *) 328 | module Of_sequence = struct 329 | type state = { mutable first: segment; 330 | mutable p: point; (* last point *) 331 | mutable last: segment; (* last segment *) 332 | mutable add : state -> point -> unit } 333 | 334 | let add_point st p = 335 | if is_valid p || is_valid st.p then ( 336 | (* The caller is responsible to setup [p] so that [is_valid(p)] 337 | is meaningful and to pass points in the increasing order of 338 | [t]. One of the two points must be valid or the segment is 339 | dropped. *) 340 | let rec s = { p0 = st.p; p1 = p; prev = st.last; next = s; 341 | witness = None } in 342 | st.last.next <- s; 343 | st.last <- s; 344 | ); 345 | st.p <- p 346 | 347 | (** "Jump" from the previous point to [p]. This will introduce a 348 | "cut" in the path ([p0] of next segment ≠ [p1] of last segment). *) 349 | let jump st p = st.p <- p 350 | 351 | let add_first_segment st p = 352 | let s = segment ~p0:st.p ~p1:p in 353 | st.first <- s; 354 | st.last <- s; 355 | st.add <- add_point 356 | 357 | (* Function used until an initial segment is added. *) 358 | let add_init st p = 359 | assert(st.first == dummy_seg); 360 | if is_valid p then ( 361 | if is_finite st.p.t then 362 | (* The previous point is maybe outside the domain (thus 363 | "invalid") but corresponds to a valid [t], so the segment 364 | may be refined to find the boundary of the domain. In 365 | particular, it is not a dummy point. *) 366 | add_first_segment st p 367 | ) 368 | else if is_valid st.p then ( 369 | (* [p] is not valid (but we assume [is_finite p.t]) but a first 370 | valid point was added previously. *) 371 | add_first_segment st p 372 | ); 373 | st.p <- p 374 | 375 | let init() = { first = dummy_seg; p = dummy_point; last = dummy_seg; 376 | add = add_init } 377 | 378 | let add st p = st.add st p 379 | 380 | let last_point st = st.p [@@inline] 381 | 382 | let close st = 383 | { seg = PQ.make(); (* costs must be computed *) 384 | first = st.first; last = st.last; vp = Box2.unit } 385 | 386 | let close_with_viewport st vp = 387 | { seg = PQ.make(); (* costs must be computed *) 388 | first = st.first; last = st.last; vp } 389 | end 390 | 391 | (** Generic box clipping *) 392 | let clip t b : [`Pt] t = 393 | if Box2.is_empty b then invalid_arg "Curve_sampling.crop: empty box"; 394 | if is_empty t then make_empty() 395 | else ( 396 | let st = Of_sequence.init() in 397 | let s = ref t.first in 398 | let continue = ref true in 399 | while !continue do 400 | (* Use Liang–Barsky algorithm to clip the segment. *) 401 | let p0 = !s.p0 and p1 = !s.p1 in 402 | let x0 = p0.x and x1 = p1.x in 403 | let y0 = p0.y and y1 = p1.y in 404 | if p0 == Of_sequence.last_point st then ( 405 | (* [p0] is the continuation of the previous segment and is in 406 | [b] (or possibly invalid) because it was added. Thus 407 | [t0=0] (see the "else" clause) and we do not determine it. *) 408 | if not(is_valid p1) then ( (* thus [p0] valid and already added *) 409 | Of_sequence.add st p1 410 | ) 411 | else if not (is_valid p0) then ( (* thus [p1] valid *) 412 | if Box2.mem (P2.v p1.x p1.y) b then Of_sequence.add st p1 413 | ) 414 | else ( 415 | (* [p0] is valid as was added. Thus is in [b] and no tests 416 | on this point are needed and the current segment will not 417 | be dropped. *) 418 | let t1 = ref 1. in 419 | (* Coordinate X. *) 420 | let dx = x1 -. x0 in 421 | (* Box2.minx b ≤ x0 ≤ Box2.maxx b *) 422 | if dx > 0. (* x0 < x1 *) then ( 423 | let r1 = (Box2.maxx b -. x0) /. dx in 424 | if r1 < !t1 then t1 := r1 425 | ) 426 | else if dx < 0. (* i.e., x0 > x1 *) then ( 427 | let r1 = (Box2.minx b -. x0) /. dx in 428 | if r1 < !t1 then t1 := r1; 429 | ); 430 | let dy = y1 -. y0 in 431 | (* Coordinate Y. *) 432 | if dy > 0. (* i.e., y0 < y1 *) then ( 433 | let r1 = (Box2.maxy b -. y0) /. dy in 434 | if r1 < !t1 then t1 := r1 435 | ) 436 | else if dy < 0. (* i.e., y0 > y1 *) then ( 437 | let r1 = (Box2.miny b -. y0) /. dy in 438 | if r1 < !t1 then t1 := r1 439 | ); 440 | (* Add the endpoint of the segment. *) 441 | (* The value of [t1] os only a linear estimate. Thus the 442 | resulting sampling is a [`Pt] one and it cannot be refined. *) 443 | Of_sequence.add st (if !t1 = 1. then p1 (* whole segment *) 444 | else { t = p0.t +. !t1 *. (p1.t -. p0.t); 445 | x = x0 +. !t1 *. dx; y = y0 +. !t1 *. dy; 446 | cost = 0. }) 447 | ) 448 | ) 449 | else ( 450 | (* [p0] was not added (jump, previous segment cut or dropped). 451 | We have to deal with both [p0] and [p1]. *) 452 | if not(is_valid p1) then ( (* thus [p0] valid *) 453 | if Box2.mem (P2.v x0 y0) b then ( 454 | Of_sequence.jump st p0; Of_sequence.add st p1) 455 | ) 456 | else if not (is_valid p0) then ( (* thus [p1] valid *) 457 | if Box2.mem (P2.v p1.x p1.y) b then ( 458 | Of_sequence.jump st p0; Of_sequence.add st p1) 459 | ) 460 | else ( 461 | let t0 = ref 0. in 462 | let t1 = ref 1. in (* convention: t1 < 0 ⇒ drop segment *) 463 | (* Coordinate X. *) 464 | let dx = x1 -. x0 in 465 | if dx = 0. then ( 466 | if x0 < Box2.minx b || x0 > Box2.maxx b then 467 | t1 := -1.; (* drop [s] *) 468 | ) 469 | else if dx > 0. (* x0 < x1 *) then ( 470 | let r0 = (Box2.minx b -. x0) /. dx in 471 | let r1 = (Box2.maxx b -. x0) /. dx in (* r0 ≤ r1 *) 472 | if r0 > !t1 || r1 < !t0 then t1 := -1. (* drop segment [s] *) 473 | else (if r0 > !t0 then t0 := r0; 474 | if r1 < !t1 then t1 := r1; ) 475 | ) 476 | else (* dx < 0 i.e., x0 > x1 *) ( 477 | let r0 = (Box2.maxx b -. x0) /. dx in 478 | let r1 = (Box2.minx b -. x0) /. dx in 479 | if r0 > !t1 || r1 < !t0 then t1 := -1. (* drop segment *) 480 | else (if r0 > !t0 then t0 := r0; 481 | if r1 < !t1 then t1 := r1; ) 482 | ); 483 | let dy = y1 -. y0 in 484 | if !t1 >= 0. (* segment not dropped *) then ( 485 | (* Coordinate Y. *) 486 | if dy = 0. (* y0 = y1 *) then ( 487 | if y0 < Box2.miny b || y0 > Box2.maxy b then 488 | t1 := -1.; (* drop [s] *) 489 | ) 490 | else if dy > 0. (* i.e., y0 < y1 *) then ( 491 | let r0 = (Box2.miny b -. y0) /. dy in 492 | let r1 = (Box2.maxy b -. y0) /. dy in (* r0 ≤ r1 *) 493 | if r0 > !t1 || r1 < !t0 then t1 := -1. (* drop segment *) 494 | else (if r0 > !t0 then t0 := r0; 495 | if r1 < !t1 then t1 := r1) 496 | ) 497 | else (* dy < 0. i.e., y0 > y1 *) ( 498 | let r0 = (Box2.maxy b -. y0) /. dy in 499 | let r1 = (Box2.miny b -. y0) /. dy in 500 | if r0 > !t1 || r1 < !t0 then t1 := -1. (* drop segment *) 501 | else (if r0 > !t0 then t0 := r0; 502 | if r1 < !t1 then t1 := r1) 503 | ) 504 | ); 505 | if !t1 >= 0. (* segment not dropped *) then ( 506 | (* FIXME: The values of [t0] and [t1] are only linear 507 | estimates. Thus the resulting sampling is a [`Pt] one 508 | and it cannot be refined. *) 509 | if !t0 = 0. then ( 510 | Of_sequence.jump st p0; 511 | if !t1 = 1. then (* whole segment *) 512 | Of_sequence.add st p1 513 | else 514 | Of_sequence.add st { t = p0.t +. !t1 *. (p1.t -. p0.t); 515 | x = x0 +. !t1 *. dx; y = y0 +. !t1 *. dy; 516 | cost = 0. } 517 | ) 518 | else ( (* t0 > 0 *) 519 | if !t1 = 1. then ( 520 | Of_sequence.jump st { t = p0.t +. !t0 *. (p1.t -. p0.t); 521 | x = x0 +. !t0 *. dx; y = y0 +. !t0 *. dy; 522 | cost = 0. }; 523 | Of_sequence.add st p1 524 | ) 525 | else ( 526 | let ds = p1.t -. p0.t in 527 | Of_sequence.jump st { t = p0.t +. !t0 *. ds; 528 | x = x0 +. !t0 *. dx; y = y0 +. !t0 *. dy; 529 | cost = 0. }; 530 | Of_sequence.add st { t = p0.t +. !t1 *. ds; 531 | x = x0 +. !t1 *. dx; y = y0 +. !t1 *. dy; 532 | cost = 0. }; 533 | ) 534 | ) 535 | ) 536 | ) 537 | ); 538 | if is_last !s then continue := false 539 | else s := !s.next; 540 | done; 541 | Of_sequence.close_with_viewport st b 542 | ) 543 | 544 | 545 | (** Uniform sampling *) 546 | let uniform ?(n=100) f a b = 547 | if not(is_finite a && is_finite b) then 548 | invalid_arg "Curve_sampling.uniform: the endpoints a and b must be finite"; 549 | if a = b then invalid_arg "Curve_sampling.uniform: empty interval"; 550 | if n < 2 then 551 | invalid_arg "Curve_sampling.uniform: need at least 2 evaluations"; 552 | let a, b = if a < b then a, b else b, a in 553 | let dx = (b -. a) /. float(n-1) in 554 | let st = Of_sequence.init () in 555 | for i = 0 to n - 1 do 556 | let x = a +. float i *. dx in 557 | let y = f x in 558 | Of_sequence.add st (point0 ~t:x ~x ~y) 559 | done; 560 | Of_sequence.close st 561 | 562 | let of_path p = 563 | let st = Of_sequence.init () in 564 | List.iteri (fun i (x,y) -> 565 | Of_sequence.add st (point0 ~t:(float i) ~x ~y) 566 | ) p; 567 | Of_sequence.close st 568 | 569 | ;; 570 | #if OCAML_VERSION >= (4, 7, 0) 571 | (* Conversion from and to [Seq]. *) 572 | 573 | let rec take_of_seq st i n seq = 574 | if i < n then 575 | match seq () with 576 | | Seq.Nil -> () 577 | | Seq.Cons ((x,y), seq) -> 578 | Of_sequence.add st (point0 ~t:(float i) ~x ~y); 579 | take_of_seq st (i + 1) n seq 580 | 581 | let of_seq ?(n=max_int) seq = 582 | let st = Of_sequence.init () in 583 | take_of_seq st 0 n seq; 584 | Of_sequence.close st 585 | 586 | (* This is supposed to return a sequence from a "connected" sub-path 587 | defined by [first] and [last]. See [fold_points_incr_segments]. *) 588 | let rec seq_of_subpath first last () = 589 | let p1 = first.p1 in 590 | if first == last then 591 | if is_valid p1 then Seq.Cons((p1.x, p1.y), Seq.empty) else Seq.Nil 592 | else 593 | Seq.Cons((p1.x, p1.y), seq_of_subpath first.next last) 594 | 595 | let seq_of_subpath_start first last () = 596 | let p0 = first.p0 in 597 | if is_valid p0 then Seq.Cons((p0.x, p0.y), seq_of_subpath first last) 598 | else seq_of_subpath first last () 599 | 600 | let rec seq_of_paths seg () = 601 | (* Determine the next connected range. *) 602 | let seg_end = ref seg in 603 | while not(is_last !seg_end) && is_valid(!seg_end.p1) 604 | && !seg_end.p1 == !seg_end.next.p0 do 605 | seg_end := !seg_end.next 606 | done; 607 | Seq.Cons(seq_of_subpath_start seg !seg_end, 608 | if is_last !seg_end then Seq.empty 609 | else seq_of_paths !seg_end.next) 610 | 611 | let to_seq t = if is_empty t then Seq.empty 612 | else seq_of_paths t.first 613 | #endif 614 | 615 | let rec add_points_before st t = function 616 | | [] -> [] 617 | | (p :: tl) as points -> 618 | if p.t < t then (Of_sequence.add st p; add_points_before st t tl) 619 | else points 620 | 621 | (* [points] is a list of pre-computed points to be inserted in the 622 | sampling. The points are assumed to be sorted in increasing 623 | order. *) 624 | let almost_uniform ~n ?viewport ~points f a b = 625 | (* Assume [a] and [b] are finite and [a] < [b]. *) 626 | (* Bounding box of initial sampling; to be used as viewport *) 627 | let xmin = ref infinity in 628 | let xmax = ref neg_infinity in 629 | let ymin = ref infinity in 630 | let ymax = ref neg_infinity in 631 | let points = ref points in 632 | let st = Of_sequence.init () in 633 | let[@inline] add_pt t = 634 | points := add_points_before st t !points; 635 | let p = f t in 636 | Of_sequence.add st p; 637 | if p.x < !xmin then xmin := p.x; (* ⇒ [x] not NaN *) 638 | if p.x > !xmax then xmax := p.x; 639 | if p.y < !ymin then ymin := p.y; 640 | if p.y > !ymax then ymax := p.y in 641 | let dt = (b -. a) /. float(n-1) in 642 | (* Slightly randomize points except for the first and last ones. *) 643 | add_pt a; 644 | add_pt (a +. 0.0625 *. dt); 645 | for i = 1 to n - 4 do 646 | add_pt (a +. (float i +. Rnd.float rnd 0.125 -. 0.0625) *. dt); 647 | done; 648 | add_pt (b -. 0.0625 *. dt); 649 | add_pt b; 650 | List.iter (fun p -> Of_sequence.add st p) !points; 651 | let vp = match viewport with 652 | | None -> 653 | if is_finite !xmin && is_finite !xmax 654 | && is_finite !ymin && is_finite !ymax then 655 | let w = !xmax -. !xmin in 656 | let w = if w = 0. then 1. else w in 657 | let h = !ymax -. !ymin in 658 | let h = if h = 0. then 1. else h in 659 | Box2.v (P2.v !xmin !ymin) (Size2.v w h) 660 | else 661 | Box2.unit 662 | | Some vp -> 663 | let w = Box2.w vp and h = Box2.h vp in 664 | if w = 0. then 665 | if h = 0. then Box2.unit 666 | else Box2.v (Box2.o vp) (Size2.v 1. h) 667 | else if h = 0. then Box2.v (Box2.o vp) (Size2.v w 1.) 668 | else vp in 669 | Of_sequence.close_with_viewport st vp 670 | 671 | 672 | module Cost = struct 673 | (* The cost of a point is a measure of the curvature of the curve at 674 | this point. This requires the points before and after to be 675 | valid. In case the point is invalid, or first, or last, it has a 676 | cost of 0. If it is an endpoint of a segment with the other 677 | point invalid, the cost is set to {!hanging_node} because the 678 | segment with the invalid point needs to be cut of too long to 679 | better determine the boundary. 680 | 681 | The cost of a point is apportioned to the segments of which it is 682 | an endpoint according to their relative lengths. More precisely, 683 | the cost c of a point p is distributed on the segments s1 and s2 684 | (of respective lengths l1 and l2) it is an endpoint of as 685 | 686 | c * l1/(l1+l2) for s1 and c * l2/(l1+l2) for s2. 687 | 688 | In order to be able to update the cost of s1 without accessing 689 | s2, p.cost holds c/(l1+l2). *) 690 | type t = Box2.t -> point -> point -> point -> float 691 | 692 | (** Cost for new "hanging" nodes — nodes created splitting a segment 693 | with an invalid endpoint. Note that this cost will be multiplied 694 | by a function of [dt] in {!segment} so it must be set high enough 695 | to ensure proper resolution of the endpoints of the domain. *) 696 | let hanging_node = 5e5 697 | 698 | (* Assume the 3 points are valid (no nan nor infinities). However, 699 | some point (x,y) values may be identical. *) 700 | let estimate: t = fun vp p1 pm p2 -> 701 | let dx1m = (p1.x -. pm.x) /. Box2.w vp 702 | and dy1m = (p1.y -. pm.y) /. Box2.h vp in 703 | let dx2m = (p2.x -. pm.x) /. Box2.w vp 704 | and dy2m = (p2.y -. pm.y) /. Box2.h vp in 705 | let len1m = hypot dx1m dy1m in 706 | let len2m = hypot dx2m dy2m in 707 | if len1m = 0. || len2m = 0. then neg_infinity (* do not subdivide *) 708 | else 709 | (* ((dx1m *. dx2m +. dy1m *. dy2m) /. (len1m *. len2m) +. 1.) *) 710 | (* (abs_float(dy2m /. dx2m -. dy1m /. dx1m)) *) 711 | let dx = -. dx1m *. dx2m -. dy1m *. dy2m in 712 | let dy = dy1m *. dx2m -. dx1m *. dy2m in 713 | atan2 dy dx (* ∈ [-π, π] *) 714 | 715 | let _dist_line: t = fun vp p1 pm p2 -> 716 | (* x ← (x - Box2.minx vp) / (Box2.h vp) and similarly for y *) 717 | let dx21 = p2.x -. p1.x and dy21 = p2.y -. p1.y in 718 | let d21 = hypot (dx21 /. Box2.w vp) (dy21 /. Box2.h vp) in 719 | if d21 = 0. then 0. (* p1 and p2 have the same (x,y) *) 720 | else 721 | let c = p2.x *. p1.y -. p2.y *. p1.x in 722 | abs_float(dy21 *. pm.x -. dx21 *. pm.y +. c) /. d21 723 | 724 | (** Compute the cost of a segment according to the costs of its 725 | endpoints. [len_t] is the length of total range of time. 726 | [len_x] and [len_y] are the dimensions of the bounding box. *) 727 | let segment ~len_t ~len_x ~len_y s = 728 | let dt = (s.p1.t -. s.p0.t) /. len_t in (* ∈ [0, 1] *) 729 | assert(0. <= dt && dt <= 1.); 730 | (* Put less efforts when [dt] is small. For functions, the 731 | Y-variation may be large but, if it happens for a small range 732 | of [t], there is no point in adding indistinguishable details. *) 733 | let dx = abs_float((s.p1.x -. s.p0.x) /. len_x) in 734 | let dy = abs_float((s.p1.y -. s.p0.y) /. len_y) in 735 | let cost = abs_float s.p0.cost +. abs_float s.p1.cost in 736 | let cost = 737 | if s.p0.cost *. s.p1.cost < 0. then 738 | (* zigzag are bad on a large scale but less important on a 739 | small scale. *) 740 | if dx <= 0.01 && dy <= 0.01 then 0.5 *. cost 741 | else if dx <= 0.05 && dy <= 0.05 then cost 742 | else 8. *. cost 743 | else cost in 744 | if dt >= 0.8 then cost 745 | else 746 | let dt = dt /. 0.8 in 747 | dt *. dt *. (6. +. (-8. +. 3. *. dt) *. dt) *. cost 748 | (* let l = hypot dx dy in 749 | * if l <= 0.001 then 0.0001 *. cost else cost *) 750 | (* if dy >= 0.2 then 2. *. cost 751 | * else if dy <= 0.05 then 0.5 *. cost 752 | * else cost *) 753 | (* dt**1.25 *. cost *) 754 | 755 | (** Assume the costs of the endpoints of [s] are up-to-date and 756 | insert [s] with the right priority. If the segment is outside 757 | the viewport ([in_vp] is [false]), add it but never look at it 758 | again (the cost is low). *) 759 | let add_with_witness sampling s ~in_vp ~len_t ~len_x ~len_y = 760 | let cost = if in_vp then segment s ~len_t ~len_x ~len_y 761 | else neg_infinity in 762 | let w = PQ.witness_add sampling.seg cost s in 763 | s.witness <- Some w 764 | 765 | (** Update the cost of all points in the sampling and add segments 766 | to the priority queue. *) 767 | let compute t ~in_vp = 768 | if not(is_empty t) then ( 769 | let len_t, len_x, len_y = len_txy t in 770 | t.first.p0.cost <- 0.; 771 | let s = ref t.first in 772 | let p0_in_vp = ref (in_vp t.first.p0) in 773 | let p_in_vp = ref false in 774 | while not(is_last !s) do 775 | (* Not the last segment, so !s.next can be used. *) 776 | let p = !s.p1 in 777 | p_in_vp := false; 778 | if is_valid p then ( 779 | p_in_vp := in_vp p; 780 | if p == !s.next.p0 then 781 | if is_valid !s.p0 && is_valid !s.next.p1 then 782 | p.cost <- estimate t.vp !s.p0 p !s.next.p1 783 | else p.cost <- hanging_node (* cut before or after [p] *) 784 | else ( (* Clean jump; seen as concatenation of 2 paths *) 785 | p.cost <- 0.; !s.next.p0.cost <- 0.) 786 | ) 787 | else p.cost <- 0.; (* [p] not valid *) 788 | add_with_witness t !s ~in_vp:(!p0_in_vp || !p_in_vp) 789 | ~len_t ~len_x ~len_y; 790 | s := !s.next; 791 | p0_in_vp := !p_in_vp; 792 | done; 793 | (* Last segment. *) 794 | t.last.p1.cost <- 0.; 795 | add_with_witness t t.last ~in_vp:(!p0_in_vp || in_vp t.last.p1) 796 | ~len_t ~len_x ~len_y; 797 | ) 798 | 799 | (* Update the cost of [s.p0] and the cost of [s.prev]. *) 800 | let update_prev s cost ~len_t ~len_x ~len_y = 801 | if not(is_first s) && s.prev.p1 == s.p0 then ( 802 | (* If [s] is first or there is a cut before the right cost has 803 | already been set. *) 804 | s.p0.cost <- cost; 805 | (match s.prev.witness with 806 | | Some w -> 807 | PQ.increase_priority (segment s.prev ~len_t ~len_x ~len_y) w 808 | | None -> assert false); 809 | ) [@@inline] 810 | 811 | let update_next s cost ~len_t ~len_x ~len_y = 812 | if not(is_last s) && s.next.p0 == s.p1 then ( 813 | s.p1.cost <- cost; 814 | (match s.next.witness with 815 | | Some w -> 816 | PQ.increase_priority (segment s.next ~len_t ~len_x ~len_y) w 817 | | None -> assert false); 818 | ) [@@inline] 819 | end 820 | 821 | 822 | (* Adaptive sampling 2D 823 | ***********************************************************************) 824 | 825 | (** Replace the segment [s] removed from the sampling [t] by [s']. *) 826 | let replace_seg_by t ~s ~s' = 827 | if is_first s then (s'.prev <- s'; t.first <- s') else s.prev.next <- s'; 828 | if is_last s then (s'.next <- s'; t.last <- s') else s.next.prev <- s' 829 | 830 | (** Replace the segment [s] removed from the sampling [t] by 2 831 | segments, [s1] followed by [s2]. *) 832 | let replace_seg_by2 t ~s ~s0 ~s1 = 833 | if is_first s then (s0.prev <- s0; t.first <- s0) else s.prev.next <- s0; 834 | if is_last s then (s1.next <- s1; t.last <- s1) else s.next.prev <- s1 835 | 836 | let refine_gen ~n f ~in_vp sampling = 837 | let len_t, len_x, len_y = len_txy sampling in 838 | let n = ref n in 839 | while !n > 0 do 840 | let s = PQ.delete_max sampling.seg in 841 | let p0 = s.p0 and p1 = s.p1 in 842 | (* let t = p0.t +. (0.4375 +. Rnf.float rnd 0.125) *. (p1.t -. p0.t) in *) 843 | (* let t = p0.t +. (0.46875 +. Rnd.float rnd 0.0625) *. (p1.t -. p0.t) in *) 844 | let t = p0.t +. 0.5 *. (p1.t -. p0.t) in 845 | (* let t = if is_last s || not(is_valid p0 && is_valid p1 && p1 == s.next.p0 846 | * && is_valid s.next.p1) then t else 847 | * let p2 = s.next.p1 in 848 | * (\* let n1 = p0.y -. p1.y and n2 = p1.x -. p0.x in 849 | * * let v0 = n1 *. p0.x +. n2 *. p0.y in 850 | * * let v1 = n1 *. p1.x +. n2 *. p1.y in 851 | * * let v2 = n1 *. p2.x +. n2 *. p2.y in 852 | * * let t' = _arg_max_quad p0.t v0 p1.t v1 p2.t v2 in *\) 853 | * let t' = _arg_max_quad p0.t p0.y p1.t p1.y p2.t p2.y in 854 | * let r = (t' -. p0.t) /. (p1.t -. p0.t) in 855 | * if 0.1 <= r && r <= 0.9 then ( 856 | * printf "%e ∈ [%e, %e]\n" t' p0.t p1.t; 857 | * t') else t in *) 858 | let p = f t in (* the caller is responsible to return a suitable point *) 859 | decr n; 860 | if is_valid p0 then 861 | if is_valid p1 then ( 862 | let rec s0 = { p0; p1 = p; prev = s.prev; next = s1; 863 | witness = None } 864 | and s1 = { p0 = p; p1; prev = s0; next = s.next; 865 | witness = None } in 866 | replace_seg_by2 sampling ~s ~s0 ~s1; 867 | (* Update costs of [p0] and [p1] and possibly of [prev] and 868 | [next] segments. *) 869 | let p_in_vp = ref false in 870 | if is_valid p then ( 871 | (* FIXME: be more efficient, e.g. decrease the number of 872 | times lengths are computed and try to reduce the number 873 | of tests. *) 874 | p_in_vp := in_vp p; 875 | p.cost <- Cost.estimate sampling.vp p0 p p1; 876 | if is_valid s.prev.p0 then ( 877 | let cost_prev = Cost.estimate sampling.vp s.prev.p0 p0 p in 878 | Cost.update_prev s0 cost_prev ~len_t ~len_x ~len_y; 879 | ); 880 | if is_valid s.next.p1 then ( 881 | let cost_next = Cost.estimate sampling.vp p p1 s.next.p1 in 882 | Cost.update_next s1 cost_next ~len_t ~len_x ~len_y; 883 | ) 884 | ) 885 | else ( (* [p] is invalid. This creates a cut between [p0] and [p1]. *) 886 | p.cost <- 0.; 887 | Cost.update_prev s0 1. ~len_t ~len_x ~len_y; 888 | Cost.update_next s1 1. ~len_t ~len_x ~len_y; 889 | ); 890 | Cost.add_with_witness sampling s0 ~in_vp:(!p_in_vp || in_vp p0) 891 | ~len_t ~len_x ~len_y; 892 | Cost.add_with_witness sampling s1 ~in_vp:(!p_in_vp || in_vp p1) 893 | ~len_t ~len_x ~len_y; 894 | ) 895 | else (* [p0] valid but not [p1]. *) 896 | if is_valid p then ( 897 | let rec s0 = { p0; p1 = p; prev = s.prev; next = s1; 898 | witness = None } 899 | and s1 = { p0 = p; p1; prev = s0; next = s.next; 900 | witness = None } in 901 | replace_seg_by2 sampling ~s ~s0 ~s1; 902 | p.cost <- Cost.hanging_node; 903 | Cost.update_prev s0 1. ~len_t ~len_x ~len_y; 904 | let p_in_vp = in_vp p in 905 | Cost.add_with_witness sampling s0 ~in_vp:(p_in_vp || in_vp p0) 906 | ~len_t ~len_x ~len_y; 907 | Cost.add_with_witness sampling s1 ~in_vp:p_in_vp 908 | ~len_t ~len_x ~len_y; 909 | ) 910 | else ( (* [p] invalid, drop segment [p, p1]. Cost(p0) stays 911 | {!Cost.hanging_node}. We can see this as reducing 912 | the uncertainty of the boundary in the segment [p0,p1]. *) 913 | let s0 = { p0; p1 = p; prev = s.prev; next = s.next; 914 | witness = None } in 915 | replace_seg_by sampling ~s ~s':s0; 916 | p.cost <- 0.; 917 | Cost.add_with_witness sampling s0 ~in_vp:(in_vp p0) 918 | ~len_t ~len_x ~len_y; 919 | ) 920 | else ( (* [p0] not valid, thus [p1] is valid. *) 921 | if is_valid p then ( 922 | let rec s0 = { p0; p1 = p; prev = s.prev; next = s1; 923 | witness = None } 924 | and s1 = { p0 = p; p1; prev = s0; next = s.next; 925 | witness = None } in 926 | replace_seg_by2 sampling ~s ~s0 ~s1; 927 | p.cost <- Cost.hanging_node; 928 | Cost.update_next s1 1. ~len_t ~len_x ~len_y; 929 | let p_in_vp = in_vp p in 930 | Cost.add_with_witness sampling s0 ~in_vp:p_in_vp 931 | ~len_t ~len_x ~len_y; 932 | Cost.add_with_witness sampling s1 ~in_vp:(p_in_vp || in_vp p1) 933 | ~len_t ~len_x ~len_y; 934 | ) 935 | else ( (* [p] invalid, drop segment [p0, p]. Cost(p1) stays 936 | {!Cost.hanging_node}. *) 937 | let s1 = { p0 = p; p1; prev = s.prev; next = s.next; 938 | witness = None } in 939 | replace_seg_by sampling ~s ~s':s1; 940 | p.cost <- 0.; 941 | Cost.add_with_witness sampling s1 ~in_vp:(in_vp p1) 942 | ~len_t ~len_x ~len_y; 943 | ) 944 | ) 945 | done; 946 | sampling 947 | 948 | let always_in_vp _p = true 949 | 950 | let param_gen fn_name ?(n=100) ?viewport ~init ~init_pt f a b = 951 | if not(is_finite a && is_finite b) then 952 | invalid_arg(fn_name ^ ": a and b must be finite"); 953 | if a = b then invalid_arg(fn_name ^ ": empty interval [a,b]"); 954 | let a, b = if a < b then a, b else b, a in 955 | (* Make sure all t are finite and in the interval [a,b]. *) 956 | let points = List.fold_left (fun l t -> 957 | if a <= t && t <= b then f t :: l 958 | else l) [] init in 959 | let points = List.fold_left (fun l p -> 960 | if a <= p.t && p.t <= b then p :: l else l) points init_pt in 961 | let points = List.sort (fun p1 p2 -> compare p1.t p2.t) points in 962 | let n0 = truncate(0.1 *. float n) in 963 | let n0 = if n0 <= 10 then 10 else n0 in 964 | let sampling = almost_uniform ~n:n0 ?viewport ~points f a b in 965 | (* to_file sampling ("/tmp/" ^ Filename.basename Sys.argv.(0) ^ "0.dat"); *) 966 | let in_vp = match viewport with 967 | | None -> always_in_vp 968 | | Some vp -> (fun p -> Box2.mem (P2.v p.x p.y) vp) in 969 | Cost.compute sampling ~in_vp; 970 | if is_empty sampling then sampling 971 | else refine_gen ~n:(n - n0) f sampling ~in_vp 972 | 973 | let fn ?n ?viewport ?(init=[]) ?(init_pt=[]) f a b = 974 | let init_pt = List.map (fun (x,y) -> point0 ~t:x ~x ~y) init_pt in 975 | let f x = let y = f x in point0 ~t:x ~x ~y in 976 | param_gen "Curve_sampling.fn" ?n ?viewport ~init ~init_pt f a b 977 | 978 | let param ?n ?viewport ?(init=[]) ?(init_pt=[]) f a b = 979 | let init_pt = List.map (fun (t,(x,y)) -> point0 ~t ~x ~y) init_pt in 980 | let f t = let (x, y) = f t in point0 ~t ~x ~y in 981 | param_gen "Curve_sampling.param" ?n ?viewport ~init ~init_pt f a b 982 | 983 | 984 | 985 | (** Sub-module using Gg point representation. *) 986 | module P2 = struct 987 | 988 | let uniform ?(n=100) f a b = 989 | if not(is_finite a && is_finite b) then 990 | invalid_arg "Curve_sampling.P2.uniform: the endpoints a and b \ 991 | must be finite"; 992 | if a = b then invalid_arg "Curve_sampling.P2.uniform: empty interval"; 993 | if n < 2 then 994 | invalid_arg "Curve_sampling.P2.uniform: need at least 2 evaluations"; 995 | let a, b = if a < b then a, b else b, a in 996 | let dt = (b -. a) /. float(n-1) in 997 | let st = Of_sequence.init () in 998 | for i = 0 to n - 1 do 999 | let t = a +. float i *. dt in 1000 | let p = f t in 1001 | Of_sequence.add st (point0 ~t ~x:(P2.x p) ~y:(P2.y p)) 1002 | done; 1003 | Of_sequence.close st 1004 | 1005 | let of_path p = 1006 | let st = Of_sequence.init () in 1007 | List.iteri (fun i p -> 1008 | Of_sequence.add st (point0 ~t:(float i) ~x:(P2.x p) ~y:(P2.y p)) 1009 | ) p; 1010 | Of_sequence.close st 1011 | 1012 | type point_or_cut = Point of P2.t | Cut 1013 | 1014 | let to_Point p = Point (P2.v p.x p.y) [@@inline] 1015 | 1016 | let to_list t = 1017 | fold_points_decr t ~init:[] (fun l p -> to_Point p :: l) 1018 | ~cut:(fun l -> Cut :: l) 1019 | ;; 1020 | #if OCAML_VERSION >= (4, 7, 0) 1021 | (* Conversion from and to [Seq]. *) 1022 | 1023 | let rec take_of_seq st i n seq = 1024 | if i < n then 1025 | match seq () with 1026 | | Seq.Nil -> () 1027 | | Seq.Cons (p, seq) -> 1028 | Of_sequence.add st (point0 ~t:(float i) ~x:(P2.x p) ~y:(P2.y p)); 1029 | take_of_seq st (i + 1) n seq 1030 | 1031 | let of_seq ?(n=max_int) seq = 1032 | let st = Of_sequence.init () in 1033 | take_of_seq st 0 n seq; 1034 | Of_sequence.close st 1035 | 1036 | (* See [fold_points_incr_segments]. *) 1037 | let rec seq_of_seg ~prev_p1 ~last_is_cut seg () = 1038 | if seg.p0 == prev_p1 then (* p0 treated *) 1039 | seq_p1 seg () 1040 | else if last_is_cut then 1041 | if is_valid seg.p0 then seq_valid_p0 seg () 1042 | else seq_valid_p1 seg () (* invalid p0 ⇒ valid p1 *) 1043 | else 1044 | Seq.Cons(Cut, if is_valid seg.p0 then seq_valid_p0 seg 1045 | else seq_valid_p1 seg) 1046 | and seq_maybe_last ~last_is_cut seg () = 1047 | if is_last seg then Seq.Nil 1048 | else seq_of_seg ~prev_p1:seg.p1 ~last_is_cut seg.next () 1049 | and seq_valid_p0 seg () = 1050 | Seq.Cons(to_Point seg.p0, seq_p1 seg) 1051 | and seq_p1 seg () = 1052 | if is_valid seg.p1 then 1053 | Seq.Cons(to_Point seg.p1, seq_maybe_last seg ~last_is_cut:false) 1054 | else (* p1 invalid ⇒ p0 valid ⇒ no cut right before. However, do 1055 | not output a Cut if last. *) 1056 | if is_last seg then Seq.Nil 1057 | else Seq.Cons(Cut, seq_of_seg ~prev_p1:seg.p1 ~last_is_cut:true seg.next) 1058 | and seq_valid_p1 seg () = 1059 | Seq.Cons(to_Point seg.p1, seq_maybe_last seg ~last_is_cut:false) 1060 | 1061 | let to_seq t = 1062 | if is_empty t then Seq.empty 1063 | else seq_of_seg t.first ~prev_p1:dummy_point ~last_is_cut:true 1064 | #endif 1065 | 1066 | let param ?n ?viewport ?(init=[]) ?(init_pt=[]) f a b = 1067 | let init_pt = 1068 | List.map (fun (t,p) -> point0 ~t ~x:(P2.x p) ~y:(P2.y p)) init_pt in 1069 | let f t = let p = f t in point0 ~t ~x:(P2.x p) ~y:(P2.y p) in 1070 | param_gen "Curve_sampling.P2.param" ?n ?viewport ~init ~init_pt f a b 1071 | end 1072 | 1073 | 1074 | 1075 | module Internal = struct 1076 | let write_points t fname = 1077 | let fh = open_out fname in 1078 | fold_points t ~init:() 1079 | (fun () p -> fprintf fh "%e\t%e\t%e\n" p.x p.y p.cost) 1080 | ~cut:(fun () -> output_char fh '\n'); 1081 | close_out fh 1082 | 1083 | let by_t (_, s1) (_, s2) = compare s1.p0.t s2.p0.t 1084 | 1085 | let write_segments t fname = 1086 | let fh = open_out fname in 1087 | (* Use the costs from the priority queue because some may have 1088 | been modified (e.g. for dropped segments). *) 1089 | let segs = PQ.foldi t.seg ~init:[] ~f:(fun l cost seg -> 1090 | (cost, seg) :: l) in 1091 | let segs = List.sort by_t segs in 1092 | List.iter (fun (cost, seg) -> 1093 | let p0 = seg.p0 and p1 = seg.p1 in 1094 | let tm = p0.t +. 0.5 *. (p1.t -. p0.t) in 1095 | fprintf fh "%e\t%e\t%e\t%e\t%e\t%e\t%e\t%e\n" 1096 | tm p0.t p0.x p0.y p1.t p1.x p1.t cost; 1097 | ) 1098 | segs; 1099 | close_out fh 1100 | 1101 | let cost_max t = PQ.max_priority t.seg 1102 | end 1103 | -------------------------------------------------------------------------------- /src/curve_sampling.mli: -------------------------------------------------------------------------------- 1 | (** Adaptive sampling of 2D curves. 2 | 3 | @version %%VERSION%% *) 4 | 5 | type _ t 6 | (** Representation of a 2D sampling. This can be thought as a path, 7 | with possible "jumps" because of discontinuities or leaving the 8 | "domain". The parameter says whether the sampling comes from 9 | evaluating a function, so it makes sense to refine it, or is just a 10 | sequence of points. *) 11 | 12 | val is_empty : _ t -> bool 13 | (** [is_empty s] returns [true] iff the sampling [s] contains no point. *) 14 | 15 | val bounding_box : _ t -> Gg.box2 16 | (** [bounding_box s] returns the smallest rectangle enclosing all the 17 | points of the sampling [s]. *) 18 | 19 | 20 | (** {2 Parametric curves} *) 21 | 22 | val fn : ?n:int -> ?viewport:Gg.Box2.t -> 23 | ?init: float list -> ?init_pt: (float * float) list -> 24 | (float -> float) -> float -> float -> [`Fn] t 25 | (** [fn f a b] returns a sampling of the graph of [f] on the interval 26 | \[[a], [b]\] by evaluating [f] at [n] points. 27 | For the optional arguments, see {!param}. *) 28 | 29 | val param : 30 | ?n:int -> ?viewport:Gg.Box2.t -> 31 | ?init: float list -> ?init_pt: (float * (float * float)) list -> 32 | (float -> float * float) -> float -> float -> [`Fn] t 33 | (** [param f a b] returns a sampling of the range of [f] on the 34 | interval \[[a], [b]\] by evaluating [f] at [n] points (or less). 35 | 36 | @param n The maximum number of evaluations of [f]. Default: [100]. 37 | If [n] ≤ 10, then [n = 10] is used instead. 38 | @param init Initial values of [t] such that [f t] must be included 39 | into the sampling in addition to the [n] evaluations. Only 40 | the values between [a] and [b] are taken into account. 41 | Default: empty. 42 | @param init_pt Initial points [(t, f t)] to include into the 43 | sampling in addition to the [n] evaluations. This allows 44 | you to use previous evaluations of [f]. Only the couples 45 | with first coordinate [t] between [a] and [b] are 46 | considered. Default: empty. *) 47 | 48 | 49 | (** {2 Uniform sampling} *) 50 | 51 | val uniform : ?n:int -> (float -> float) -> float -> float -> [`Fn] t 52 | (** [uniform f a b] returns a sampling of the graph of [f] on [n] 53 | equidistant points in the interval \[[a], [b]\] (the boundaries 54 | [a] and [b] being always included — so [n >= 2]). The resulting 55 | sampling may have less than [n] points because evaluations 56 | returning points with NaN components are discarded (they split the 57 | path). 58 | 59 | @param n the number of points. If [n <= 2] is given, it is 60 | considered as if [n=2] was passed. Default: [n = 100]. *) 61 | 62 | 63 | (** {2 Relation to sequences} *) 64 | 65 | val of_path : (float * float) list -> [`Pt] t 66 | (** Use the provided path as the sampling. *) 67 | 68 | val to_list : _ t -> (float * float) list list 69 | (** [to_list t] return the sampling as a list of connected components 70 | of the path, each of which is given as a list of (x,y) couples. *) 71 | 72 | ;; 73 | #if OCAML_VERSION >= (4, 7, 0) 74 | val of_seq : ?n: int -> (float * float) Seq.t -> [`Pt] t 75 | (** [of_seq seq] convert the sequence of points [seq] to a sampling. 76 | 77 | @param n only takes at most the first [n] entries. If [n] is not 78 | set (the default), this function may run into an infinite loop. *) 79 | 80 | val to_seq : _ t -> (float * float) Seq.t Seq.t 81 | (** [to_seq t] convert [t] to a sequence of connected compononent. *) 82 | #endif 83 | 84 | (** {2 Transforming samplings} *) 85 | 86 | val tr : Gg.m3 -> _ t -> [`Pt] t 87 | (** [tr m t] apply the transform [m] on [t]. See {!Gg.P2.tr} for more 88 | details. *) 89 | 90 | val clip : _ t -> Gg.box2 -> [`Pt] t 91 | (** [clip t b] returns the sampling [t] but clipped to the 2D box. A 92 | path that crosses the boundary will get additional nodes at the 93 | points of crossing and the part outside the bounding box will be 94 | dropped. (Thus a path entirely out of the bounding box will be 95 | removed.) *) 96 | 97 | 98 | (** {2 GG interface} *) 99 | 100 | (** Interface using [Gg.p2] to represent points. *) 101 | module P2 : sig 102 | val param : ?n:int -> ?viewport:Gg.Box2.t -> 103 | ?init: float list -> ?init_pt: (float * Gg.p2) list -> 104 | (float -> Gg.p2) -> float -> float -> [`Fn] t 105 | (** See {!Curve_sampling.param}. *) 106 | 107 | val uniform : ?n:int -> (float -> Gg.p2) -> float -> float -> [`Fn] t 108 | (** [uniform f a b] return a sampling of the image of [f] on [n] 109 | equidistant points in the interval \[[a], [b]\] (the boundaries 110 | [a] and [b] being always included — so [n >= 2]). 111 | 112 | @param n the number of points. If [n <= 2] is given, it is 113 | considered as if [n=2] was passed. Default: [n = 100]. *) 114 | 115 | val of_path : Gg.p2 list -> [`Pt] t 116 | (** Use the provided path as the sampling. *) 117 | 118 | type point_or_cut = Point of Gg.p2 | Cut 119 | 120 | val to_list : _ t -> point_or_cut list 121 | (** [to_list s] return the sampling as a list of points in 122 | increasing order of the parameter of the curve. The curve is 123 | possibly made of several pieces separated by a single [Cut]. *) 124 | 125 | #if OCAML_VERSION >= (4, 7, 0) 126 | val of_seq : ?n: int -> Gg.p2 Seq.t -> [`Pt] t 127 | (** See {! Curve_sampling.of_seq}. *) 128 | 129 | val to_seq : _ t -> point_or_cut Seq.t 130 | (** See {! Curve_sampling.to_seq}. *) 131 | ;; 132 | #endif 133 | end 134 | 135 | (** {2 Save the sampling data} *) 136 | 137 | val to_channel : _ t -> out_channel -> unit 138 | (** [to_channel t ch] writes the sampling [t] to the channel [ch]. 139 | Each point is written as "x y" on a single line (in scientific 140 | notation). If the path is interrupted, a blank line is printed. 141 | This format is compatible with gnuplot. *) 142 | 143 | val to_file : _ t -> string -> unit 144 | (** [to_file t fname] saves the sampling [t] to the file [fname] using 145 | the format described in {!to_channel}. *) 146 | 147 | val to_latex : 148 | _ t -> ?n: int -> ?arrow: string -> ?arrow_pos: float -> ?color: Gg.color -> 149 | string -> unit 150 | (** [to_latex t fname] saves the sampling [t] as PGF/TikZ commands. 151 | @param n the maximum number of points of PGF path (after which the 152 | sampling curve is drawn as several PGF paths). 153 | Default: [20_000]. 154 | @param arrow The type of arrow to draw. See the TikZ manual. 155 | If [arrow_pos] is specified and not this, it defaults to ">". 156 | @param arrow_pos the position of the arrow as a percent of the curve 157 | length (in the interval \[0.,1.\]). If [arrow] is specified 158 | but not this, it defaults to [0.5]. 159 | @param color specify the color of the curve. *) 160 | 161 | val to_latex_channel : 162 | _ t -> ?n: int -> ?arrow: string -> ?arrow_pos: float -> ?color: Gg.color -> 163 | out_channel -> unit 164 | (** [to_latex_channel t ch] writes the sampling [t] as PGF/TikZ 165 | commands to the channel [ch]. See {!to_latex} for the meaning of 166 | optional arguments. *) 167 | 168 | 169 | (**/**) 170 | 171 | (** Functions outputting internal information about the sampling. 172 | They may change any time without prior notice. *) 173 | module Internal : sig 174 | val write_points : _ t -> string -> unit 175 | (** [write_points t fname] same as [to_file t fname] except that a third 176 | column containing the cost of the points is present. *) 177 | 178 | val write_segments : _ t -> string -> unit 179 | (** [write_segments t fname] write the segments in the sampling. 180 | Each segment is outputted as a line [tm t1 x1 y1 t2 x2 y2 cost] 181 | where [tm] is the middle point between [t1] and [t2]. *) 182 | 183 | val cost_max : _ t -> float 184 | (** Return the maximum cost of the segments. *) 185 | ;; 186 | end 187 | 188 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name curve_sampling) 3 | (public_name curve-sampling) 4 | (flags :standard -safe-string) 5 | (preprocess (action (run %{bin:cppo} -V OCAML:%{ocaml_version} %{input-file}))) 6 | (libraries gg) 7 | (synopsis "Sampling of parametric and implicit curves")) 8 | -------------------------------------------------------------------------------- /tests/abs.gp: -------------------------------------------------------------------------------- 1 | set terminal pdfcairo 2 | set output "abs.pdf" 3 | set grid 4 | set y2tics 5 | 6 | plot "abs0.dat" with l lt 5 title "function", \ 7 | "abs.dat" with l lt 1 title "n = 40" 8 | 9 | plot "abs0.dat" with l lt 5 title "function", \ 10 | "abs.dat" with p lt 1 pt 6 ps 0.5 title "n = 40", \ 11 | "abs_s.dat" using 1:8 with lp ps 0.2 lt rgb "#3f3f3f" axes x1y2 \ 12 | title "cost segments" 13 | 14 | plot "abs1.dat" with l lt 5 title "|sin x|", \ 15 | "abs2.dat" with l lt 1 title "n = 50" 16 | plot "abs1.dat" with l lt 5 title "|sin x|", \ 17 | "abs2.dat" with p lt 1 pt 6 ps 0.5 title "n = 50", \ 18 | "abs2_s.dat" using 1:8 with lp ps 0.2 lt rgb "#3f3f3f" axes x1y2 \ 19 | title "cost segments" 20 | 21 | -------------------------------------------------------------------------------- /tests/abs.ml: -------------------------------------------------------------------------------- 1 | let two_pi = 2. *. acos(-1.) 2 | 3 | let () = 4 | let xmin = -1. and xmax = 1.2 in 5 | let f x = if x <= 0.5 then abs_float x else 1. -. x in 6 | let t0 = Curve_sampling.uniform f xmin xmax ~n:1000 in 7 | Curve_sampling.to_file t0 "abs0.dat"; 8 | let t = Curve_sampling.fn f xmin xmax ~n:40 in 9 | Curve_sampling.to_file t "abs.dat"; 10 | Curve_sampling.Internal.write_segments t "abs_s.dat"; 11 | 12 | let f x = abs_float(sin x) in 13 | let t0 = Curve_sampling.uniform f 0. two_pi ~n:1000 in 14 | Curve_sampling.to_file t0 "abs1.dat"; 15 | let t = Curve_sampling.fn f 0. two_pi ~n:50 in 16 | Curve_sampling.to_file t "abs2.dat"; 17 | Curve_sampling.Internal.write_segments t "abs2_s.dat" 18 | -------------------------------------------------------------------------------- /tests/clip.gp: -------------------------------------------------------------------------------- 1 | set terminal pdfcairo 2 | set output "clip_gp.pdf" 3 | 4 | set grid 5 | set title "Path clipped to [0,1]²" 6 | plot "clip0.dat" with l lt 1, "clip1.dat" with l lt 6 lw 3 7 | 8 | set title "Vertical asymptote at x=1/4" 9 | plot [-0.5:5.5] [-4:2] "clip2.dat" with filledcurves y1=0 lt 5, \ 10 | "clip3.dat" with l lt 1, \ 11 | "clip4.dat" with l lt 6 lw 3 12 | 13 | unset title 14 | plot [-0.5:5.5] [-10:2] "clip2.dat" with filledcurves y1=0 lt 5, \ 15 | "clip3.dat" with p lt 1 pt 7 ps 0.2 16 | -------------------------------------------------------------------------------- /tests/clip.ml: -------------------------------------------------------------------------------- 1 | open Gg 2 | 3 | let () = 4 | let b = Box2.v (P2.v 0. 0.) (Size2.v 1. 1.) in 5 | let t = Curve_sampling.of_path 6 | [(0., -0.5); (1.5, 1.); (0.2, 0.5); (0.3, 1.5); (1., 0.6); 7 | (nan, nan); (-0.5, 0.5); (-1., 0.); (0.5, 0.5)] in 8 | Curve_sampling.to_file t "clip0.dat"; 9 | Curve_sampling.to_latex t "clip0.tex"; 10 | let t1 = Curve_sampling.clip t b in 11 | Curve_sampling.to_file t1 "clip1.dat"; 12 | Curve_sampling.to_latex t1 "clip1.tex" 13 | 14 | let () = 15 | let f x = (8. *. x**2. -. 10. *. x -. 1.) /. (1. -. 4. *. x)**2. in 16 | let s0 = Curve_sampling.uniform f 0. 5.3 in 17 | let s1 = Curve_sampling.fn f 0. 5.3 in 18 | let s2 = Curve_sampling.clip s1 (Box2.v (V2.v 0. (-2.)) (Size2.v 5. 2.)) in 19 | Curve_sampling.to_file s0 "clip2.dat"; 20 | Curve_sampling.to_file s1 "clip3.dat"; 21 | Curve_sampling.to_file s2 "clip4.dat" 22 | -------------------------------------------------------------------------------- /tests/clip.tex: -------------------------------------------------------------------------------- 1 | \documentclass[12pt,a4paper]{article} 2 | 3 | \usepackage{tikz} 4 | 5 | \begin{document} 6 | 7 | \begin{tikzpicture}[x=30mm, y=30mm] 8 | \draw[->] (-1.2, 0) -- (1.7, 0); 9 | \draw[->] (0, -0.7) -- (0, 1.7); 10 | \foreach \x in {-1, -0.5, 0.5, 1, 1.5}{ 11 | \draw (\x, 3pt) -- (\x, -3pt) node[below]{$\scriptstyle \x$}; 12 | } 13 | \foreach \y in {-0.5, 0.5, 1, 1.5}{ 14 | \draw (3pt, \y) -- (-3pt, \y) node[left]{$\scriptstyle \y$}; 15 | } 16 | \draw[dashed] (0,0) rectangle (1,1); 17 | \begin{scope}[color=red, line width=3pt] 18 | \input{clip1.tex} 19 | \end{scope} 20 | \begin{scope}[color=blue] 21 | \input{clip0.tex} 22 | \end{scope} 23 | \end{tikzpicture} 24 | 25 | \end{document} 26 | %%% Local Variables: 27 | %%% mode: latex 28 | %%% TeX-master: t 29 | %%% End: 30 | -------------------------------------------------------------------------------- /tests/dom.gp: -------------------------------------------------------------------------------- 1 | set terminal pdfcairo 2 | set output "dom.pdf" 3 | set grid 4 | 5 | plot [-0.2:] "dom0.dat" with l lt 5, "dom.dat" with l lt 1 6 | 7 | plot [-0.2:] "dom0.dat" with l lt 5, "dom.dat" with p lt 1 pt 6 ps 0.5 8 | 9 | plot [-0.2:] [0:1000] "dom1.dat" with l lt 5, "dom2.dat" with l lt 1 10 | 11 | plot [-0.2:] [0:1000] "dom1.dat" with l lt 5, \ 12 | "dom2.dat" with p lt 1 pt 6 ps 0.6, \ 13 | "dom3.dat" with p lt 2 pt 2 ps 0.3 14 | 15 | set title "With viewport [0,2] × [0,3]" 16 | plot [-0.2:] [0:4] "dom1.dat" with l lt 5 title "1/x for x > 0", \ 17 | "dom3.dat" with p lt 2 pt 2 ps 0.5 title "with viewport" 18 | 19 | set title "With an without viewport" 20 | plot [-1:2] [-100:100] \ 21 | "dom5.dat" with lp lt 1 pt 6 ps 0.5 title "no viewport", \ 22 | "dom4.dat" with lp lt 2 pt 2 ps 0.5 title "with viewport" 23 | 24 | set title "Heaviside function" 25 | plot [-1:2] "dom6.dat" with l lt 5, \ 26 | "dom7.dat" with p lt 1 pt 6 ps 0.5 27 | 28 | set title "lngamma on [-4,8]" 29 | plot [-4:8] [-2:15] "dom8.dat" with l lt 5 title "log |Γ(x)|", \ 30 | "dom9.dat" with p lt 1 pt 6 ps 0.5 title "n = 203" 31 | -------------------------------------------------------------------------------- /tests/dom.ml: -------------------------------------------------------------------------------- 1 | open Gg 2 | open Gsl.Sf 3 | 4 | let () = 5 | let xmin = -1. and xmax = 2. in 6 | let f = sqrt in 7 | let t0 = Curve_sampling.uniform f xmin xmax ~n:1000 in 8 | Curve_sampling.to_file t0 "dom0.dat"; 9 | let t = Curve_sampling.fn f xmin xmax ~n:50 in 10 | Curve_sampling.to_file t "dom.dat"; 11 | 12 | let f x = if x > 0. then 1. /. x else nan in 13 | let t0 = Curve_sampling.uniform f 1e-3 xmax ~n:1000 in 14 | Curve_sampling.to_file t0 "dom1.dat"; 15 | let t = Curve_sampling.fn f xmin xmax in 16 | Curve_sampling.to_file t "dom2.dat"; 17 | let t = Curve_sampling.fn f xmin xmax 18 | ~viewport:(Box2.v (P2.v 0. 0.) (Size2.v 2. 3.)) in 19 | Curve_sampling.to_file t "dom3.dat"; 20 | 21 | let f x = 1. /. x in 22 | let t = Curve_sampling.fn f xmin xmax 23 | ~viewport:(Box2.v (P2.v (-1.) (-100.)) (Size2.v 3. 200.)) in 24 | Curve_sampling.to_file t "dom4.dat"; 25 | let t1 = Curve_sampling.fn f xmin xmax in 26 | Curve_sampling.to_file t1 "dom5.dat"; 27 | 28 | let f x = if x < 0. then -1. else 1. in 29 | let t = Curve_sampling.fn f xmin xmax ~n:1000 in 30 | Curve_sampling.to_file t "dom6.dat"; 31 | let t1 = Curve_sampling.fn f xmin xmax in 32 | Curve_sampling.to_file t1 "dom7.dat"; 33 | 34 | let f x = try lngamma x with Gsl.Error.Gsl_exn(EDOM, _) -> nan in 35 | let t = Curve_sampling.fn f (-4.) 8. ~n:3000 in 36 | Curve_sampling.to_file t "dom8.dat"; 37 | let t1 = Curve_sampling.fn f (-4.) 8. ~n:203 38 | ~viewport:(Box2.v (P2.v (-4.) (-10.)) (Size2.v 12. 25.)) in 39 | Curve_sampling.to_file t1 "dom9.dat"; 40 | -------------------------------------------------------------------------------- /tests/dune: -------------------------------------------------------------------------------- 1 | (executables 2 | (names clip nice osc abs dom horror sequences latex_speed empty) 3 | (preprocess (action (run %{bin:cppo} -V OCAML:%{ocaml_version} %{input-file}))) 4 | (libraries curve_sampling gsl)) 5 | 6 | (rule 7 | (targets clip_gp.pdf) 8 | (deps (:p clip.exe) clip.gp) 9 | (action (progn 10 | (run %{p}) 11 | (run gnuplot clip.gp)))) 12 | (rule 13 | (targets clip.pdf) 14 | (deps (:p clip.exe) clip.tex) 15 | (action (progn 16 | (run %{p}) 17 | (run pdflatex -interaction=batchmode clip.tex)))) 18 | 19 | (rule 20 | (targets nice.pdf) 21 | (deps (:p nice.exe) nice.gp) 22 | (action (progn 23 | (run %{p}) 24 | (run gnuplot nice.gp)))) 25 | 26 | 27 | (rule 28 | (targets osc.pdf) 29 | (deps (:p osc.exe) osc.gp) 30 | (action (progn 31 | (run %{p}) 32 | (run gnuplot osc.gp)))) 33 | 34 | (rule 35 | (targets abs.pdf) 36 | (deps (:p abs.exe) abs.gp) 37 | (action (progn 38 | (run %{p}) 39 | (run gnuplot abs.gp)))) 40 | 41 | (rule 42 | (targets dom.pdf) 43 | (deps (:p dom.exe) dom.gp) 44 | (action (progn 45 | (run %{p}) 46 | (run gnuplot dom.gp)))) 47 | 48 | (rule 49 | (targets horror.pdf) 50 | (deps horror.exe) 51 | (action (progn 52 | (run %{deps}) ; also generates horror.gp 53 | (run gnuplot horror.gp)))) 54 | 55 | (alias 56 | (name runtest) 57 | (deps clip_gp.pdf nice.pdf osc.pdf abs.pdf dom.pdf horror.pdf 58 | sequences.exe) 59 | (action (run %{exe:sequences.exe}))) 60 | 61 | (alias 62 | (name runtest) 63 | (action (run %{exe:empty.exe}))) 64 | 65 | (alias 66 | (name latex) 67 | (deps clip.pdf (:s latex_speed.exe)) 68 | (action (progn 69 | (run %{s}) 70 | (ignore-stdout 71 | (run time pdflatex -interaction=nonstopmode latex_speed.tex))))) 72 | -------------------------------------------------------------------------------- /tests/empty.ml: -------------------------------------------------------------------------------- 1 | module C = Curve_sampling 2 | 3 | (* Produce empty samplings *) 4 | 5 | let () = 6 | (try ignore(C.fn (fun _ -> 1.) 0. 0.); 7 | (* Expected to say that the interval is empty. *) 8 | assert false 9 | with Invalid_argument _ -> ()); 10 | 11 | let s = C.fn (fun _ -> nan) 0. 1. in 12 | assert(C.is_empty s); 13 | 14 | let s = C.fn (fun x -> if x = 0. || x = 1. then x else nan) 0. 1. in 15 | assert(List.length (C.to_list s) = 2); 16 | 17 | let s = C.param (fun _ -> (nan, nan)) 0. 1. in 18 | assert(C.is_empty s) 19 | 20 | 21 | -------------------------------------------------------------------------------- /tests/horror.ml: -------------------------------------------------------------------------------- 1 | open Printf 2 | open Gg 3 | 4 | let () = 5 | let fh = open_out "horror.gp" in 6 | fprintf fh "set terminal pdfcairo\n\ 7 | set output \"horror.pdf\"\n\ 8 | set grid\n"; 9 | let n_dat = ref 0 in 10 | let plot ?(xmin = -5.) ?(xmax = 5.) ?(ymin = -5.) ?(ymax = 5.) ?(n=100) 11 | ?init ~title f = 12 | let vp = Box2.v (P2.v xmin ymin) (Size2.v (xmax -. xmin) (ymax -. ymin)) in 13 | let s = Curve_sampling.fn f xmin xmax ~viewport:vp ~n ?init in 14 | incr n_dat; 15 | let fname = sprintf "horror%d.dat" !n_dat in 16 | Curve_sampling.to_file s fname; 17 | let fname_p = sprintf "horror%d_p.dat" !n_dat in 18 | Curve_sampling.Internal.write_points s fname_p; 19 | let fname_s = sprintf "horror%d_s.dat" !n_dat in 20 | Curve_sampling.Internal.write_segments s fname_s; 21 | fprintf fh "unset title\n\ 22 | unset y2tics\n\ 23 | plot [%f:%f] \"%s\" with l lt 5 title \"%s\", \ 24 | \"%s\" with p lt 1 pt 6 ps 0.2 title \"n=%d\"\n" 25 | xmin xmax fname title fname n; 26 | fprintf fh "set title \"Restricted to viewport [%g:%g]×[%g:%g]\"\n\ 27 | set y2tics\n\ 28 | set y2range [-1e-6: %f]\n\ 29 | plot [%f:%f] [%f:%f] \"%s\" with l lt 5 title \"%s\", \ 30 | \"%s\" with p lt 3 pt 7 ps 0.2 title \"n=%d\", \ 31 | \"%s\" using 1:3 with lp ps 0.2 lt rgb \"#737373\" \ 32 | title \"cost points\", \ 33 | \"%s\" using 1:8 with lp ps 0.2 lt rgb \"#760b0b\" \ 34 | axes x1y2 title \"cost segments\"\n" 35 | xmin xmax ymin ymax (Curve_sampling.Internal.cost_max s +. 1e-6) 36 | xmin xmax ymin ymax fname title fname n fname_p fname_s; 37 | in 38 | (* Tests from 39 | https://github.com/soegaard/bracket/blob/master/plotting/adaptive-plotting.rkt#L225 *) 40 | plot (fun _x -> 2.) ~title:"x ↦ 2" ~n:10; 41 | plot (fun x -> x) ~title:"x ↦ x"; 42 | plot (fun x -> 5. *. x) ~title:"x ↦ 5x"; 43 | plot (fun x -> 1e6 *. x) ~title:"10⁶ x"; (* high slope *) 44 | plot (fun x -> 1e50 *. x) ~title:"10⁵⁰ x"; (* high slope *) 45 | plot (fun x -> 1. /. x) ~title:"1/x"; (* check singularity *) 46 | plot (fun x -> 1. /. x) ~title:"1/x" (* singularity at starting point *) 47 | ~xmin:0. ~xmax:5. ~ymax:100.; 48 | plot sqrt ~title:"√x" ~xmin:(-0.3) ~xmax:2. ~ymin:0. ~ymax:1.6 ~n:50; 49 | plot sqrt ~title:"√x" ~xmin:(-1.) ~xmax:2. ~ymin:0. ~ymax:1.6 ~n:50; 50 | plot tan ~title:"tan" ~n:200; (* many singularities *) 51 | plot (fun x -> 1. /. (abs_float x)) ~title:"1/|x|"; 52 | plot (fun x -> log(1. +. sin (cos x))) ~title:"1 + sin(cos x)" 53 | ~xmin:(-6.) ~xmax:6. ~ymin:(-2.) ~ymax:2.; 54 | plot (fun x -> sin(x**3.) +. cos(x**3.)) ~title:"sin x³ + cos x³" ~n:400 55 | ~xmin:0. ~xmax:6.28 ~ymin:(-1.5) ~ymax:1.5; 56 | plot sin ~title:"sin" ~n:400 57 | ~xmin:(-5.) ~xmax:200. ~ymin:(-1.) ~ymax:1.; 58 | (* Examples from R. Avitzur, O. Bachmann, N. Kajler, "From Honest to 59 | Intelligent Plotting", proceedings of ISSAC' 95, pages 32-41, July 1995. *) 60 | plot (fun x -> sin(300. *. x)) ~title:"sin(300 x)" 61 | ~xmin:(-4.) ~xmax:4. ~ymin:(-1.) ~ymax:1.; 62 | plot (fun x -> sin(300. *. x)) ~title:"sin(300 x)" ~n:1000 63 | ~xmin:(-4.) ~xmax:4. ~ymin:(-1.) ~ymax:1.; 64 | plot (fun x -> sin(300. *. x)) ~title:"sin(310 x)" 65 | ~xmin:(-4.) ~xmax:4. ~ymin:(-1.) ~ymax:1.; 66 | plot (fun x -> 1. +. x *. x +. 0.0125 *. log(abs_float(1. -. 3. *. (x -. 1.)))) 67 | ~title:"1 + x² + 0.0125 log|1 - 3(x-1)|" 68 | ~xmin:(-2.) ~xmax:2. ~ymin:0. ~ymax:3.; 69 | plot (fun x -> 1. +. x *. x +. 0.0125 *. log(abs_float(1. -. 3. *. (x -. 1.)))) 70 | ~title:"1 + x² + 0.0125 log|1 - 3(x-1)| (specifying x=4/3)" 71 | ~xmin:(-2.) ~xmax:2. ~ymin:0. ~ymax:3. ~init:[4. /. 3.] ~n:300; 72 | plot (fun x -> x *. sin(1. /. x)) ~title:"x sin(1/x)" 73 | ~xmin:(-0.5) ~xmax:0.5 ~ymin:(-1.) ~ymax:1.; 74 | plot (fun x -> x *. sin(1. /. x)) ~title:"x sin(1/x)" ~n:200 75 | ~xmin:(-0.5) ~xmax:0.5 ~ymin:(-1.) ~ymax:1.; 76 | plot (fun x -> sin(1. /. x)) ~title:"sin(1/x)" 77 | ~xmin:(-2.) ~xmax:2. ~ymin:(-1.) ~ymax:1.; 78 | plot (fun x -> sin(1. /. x)) ~title:"sin(1/x)" ~n:400 79 | ~xmin:(-2.) ~xmax:2. ~ymin:(-1.) ~ymax:1.; 80 | plot (fun x -> sin(x**4.)) ~title:"sin(x⁴)" 81 | ~xmin:(-4.) ~xmax:4. ~ymin:(-1.) ~ymax:1.; 82 | plot (fun x -> sin(x**4.)) ~title:"sin(x⁴)" ~n:600 83 | ~xmin:(-4.) ~xmax:4. ~ymin:(-1.) ~ymax:1.; 84 | plot (fun x -> sin(exp x)) ~title:"sin(exp x)" 85 | ~xmin:(-6.) ~xmax:6. ~ymin:(-1.) ~ymax:1.; 86 | plot (fun x -> sin(exp x)) ~title:"sin(exp x)" ~n:500 87 | ~xmin:(-6.) ~xmax:6. ~ymin:(-1.) ~ymax:1.; 88 | plot (fun x -> 1. /. sin x) ~title:"1 / sin x" 89 | ~xmin:(-10.) ~xmax:10. ~ymin:0. ~ymax:10.; 90 | plot (fun x -> sin x /. x) ~title:"(sin x)/x" 91 | ~xmin:(-6.) ~xmax:6. ~ymin:0. ~ymax:2.; 92 | plot (fun x -> tan(x**3. -. x +. 1.) +. 1. /. (x +. 3. *. exp x)) 93 | ~title:"tan(x³ - x + 1) + 1/(x + 3 eˣ)" 94 | ~xmin:(-2.) ~xmax:2. ~ymin:(-15.) ~ymax:15.; 95 | plot (fun s -> (1. +. cos s) *. exp(-0.1 *. s)) 96 | ~title:"(1 + cos x) exp(-x/10)" 97 | ~xmin:0. ~xmax:17. ~ymin:0. ~ymax:2.; 98 | plot (fun s -> (1. +. cos s) *. exp(-0.1 *. s)) 99 | ~title:"(1 + cos x) exp(-x/10)" 100 | ~xmin:(-2.) ~xmax:17. ~ymin:0. ~ymax:2.; 101 | plot (fun s -> (1. +. cos s) *. exp(-0.01 *. s**2.)) 102 | ~title:"(1 + cos x) exp(-x²/100)" 103 | ~xmin:0. ~xmax:17. ~ymin:0. ~ymax:2.; 104 | close_out fh 105 | -------------------------------------------------------------------------------- /tests/latex_speed.ml: -------------------------------------------------------------------------------- 1 | open Printf 2 | 3 | let () = 4 | let fh = open_out "latex_speed.tex" in 5 | fprintf fh "\\documentclass[12pt,a4paper]{article}\n\ 6 | \\usepackage{tikz}\n\ 7 | \\begin{document}\n\ 8 | \\begin{tikzpicture}\n"; 9 | let n = 40_000 in 10 | printf "🛈 Will measure LaTeX speed with %d points.\n%!" n; 11 | let t = Curve_sampling.fn sin (-6.) 6. ~n in 12 | Curve_sampling.to_latex_channel t fh; 13 | fprintf fh "\\end{tikzpicture}\n\ 14 | \\end{document}"; 15 | close_out fh 16 | 17 | 18 | (* Local Variables: *) 19 | (* compile-command: "dune build latex_speed.exe" *) 20 | (* End: *) 21 | -------------------------------------------------------------------------------- /tests/nice.gp: -------------------------------------------------------------------------------- 1 | set terminal pdfcairo 2 | set output "nice.pdf" 3 | 4 | set grid 5 | set title "Graph of a nice parametric curve" 6 | plot "nice0.dat" with l lt 2, "nice1.dat" with lp lt 1 pt 6 ps 0.5 7 | 8 | set title "exp(-x²), n=53" 9 | plot "nice2.dat" with l lt 5 lw 3, "nice3.dat" with lp lt 7 pt 6 ps 0.5 10 | -------------------------------------------------------------------------------- /tests/nice.ml: -------------------------------------------------------------------------------- 1 | open Gg 2 | 3 | let () = 4 | let f t = P2.v (cos t) (sin (2. *. t)) in 5 | let t0 = Curve_sampling.P2.uniform f 0. Float.two_pi ~n:1000 in 6 | Curve_sampling.to_file t0 "nice0.dat"; 7 | let t = Curve_sampling.P2.param f 0. Float.two_pi in 8 | Curve_sampling.to_file t "nice1.dat"; 9 | 10 | let f x = exp(-. (x**2.)) in 11 | let t0 = Curve_sampling.uniform f (-2.5) 2.5 ~n:1000 in 12 | Curve_sampling.to_file t0 "nice2.dat"; 13 | let t = Curve_sampling.fn f (-2.5) 2.5 ~n:53 in 14 | Curve_sampling.to_file t "nice3.dat"; 15 | -------------------------------------------------------------------------------- /tests/osc.gp: -------------------------------------------------------------------------------- 1 | set terminal pdfcairo 2 | set output "osc.pdf" 3 | 4 | set grid 5 | set title "Graph of x * sin(1/x), 227 eval" 6 | plot "osc0.dat" with filledcurves y1=0 lt 5, "osc227.dat" with l lt 7 7 | set title "Graph of x * sin(1/x), 389 eval" 8 | plot "osc0.dat" with filledcurves y1=0 lt 5, "osc389.dat" with l lt 2 9 | 10 | set title "Graph of x * sin(1/x), 227 eval" 11 | plot "osc0.dat" with filledcurves y1=0 lt 5, \ 12 | "osc227.dat" with p lt 7 pt 7 ps 0.15 13 | set title "Graph of x * sin(1/x), 389 eval" 14 | plot "osc0.dat" with filledcurves y1=0 lt 5, \ 15 | "osc389.dat" with p lt 2 pt 6 ps 0.15 16 | 17 | 18 | set title "Graph of sin(1/x)" 19 | plot "osc1.dat" with filledcurves y1=0 lt 5, "osc2.dat" with l lt 1 20 | unset title 21 | plot "osc1.dat" with filledcurves y1=0 lt 5, \ 22 | "osc2.dat" with p lt 1 pt 7 ps 0.15 23 | 24 | set title "Graph of sin on [-42π, 42π]" 25 | plot "osc3.dat" with l lt 1 26 | 27 | set title "Graph of x ↦ sin(42x) on [-π, π]" 28 | plot "osc4.dat" with l lt 1 29 | -------------------------------------------------------------------------------- /tests/osc.ml: -------------------------------------------------------------------------------- 1 | 2 | let pi = acos(-1.) 3 | 4 | let () = 5 | let f x = if x = 0. then 0. else x *. sin (1. /. x) in 6 | let xmin = -0.4 and xmax = 0.4 in 7 | let t0 = Curve_sampling.uniform f xmin xmax ~n:1000 in 8 | Curve_sampling.to_file t0 "osc0.dat"; 9 | let t = Curve_sampling.fn f xmin xmax ~n:227 in 10 | Curve_sampling.to_file t "osc227.dat"; 11 | let t = Curve_sampling.fn f xmin xmax ~n:389 in 12 | Curve_sampling.to_file t "osc389.dat"; 13 | 14 | let f x = sin (1. /. x) in 15 | let t0 = Curve_sampling.uniform f xmin xmax ~n:1000 in 16 | Curve_sampling.to_file t0 "osc1.dat"; 17 | let t = Curve_sampling.fn f xmin xmax ~n:391 in 18 | Curve_sampling.to_file t "osc2.dat"; 19 | 20 | let t = Curve_sampling.fn sin (-42. *. pi) (42. *. pi) ~n:400 in 21 | Curve_sampling.to_file t "osc3.dat"; 22 | 23 | let t = Curve_sampling.fn (fun x -> sin(42. *. x)) (-.pi) pi ~n:400 in 24 | Curve_sampling.to_file t "osc4.dat" 25 | -------------------------------------------------------------------------------- /tests/sequences.ml: -------------------------------------------------------------------------------- 1 | (* Test conversions from and to sequences. *) 2 | 3 | let point x y = Curve_sampling.P2.Point (Gg.P2.v x y) 4 | 5 | let () = 6 | let s = Curve_sampling.of_path [(1.,1.); (2.,2.); (3., nan); (4.,4.)] in 7 | let out = [[(1.,1.); (2.,2.)]; [(4.,4.)]] in 8 | let out_p2 = [point 1. 1.; point 2. 2.; Curve_sampling.P2.Cut; 9 | point 4. 4.] in 10 | assert(Curve_sampling.to_list s = out); 11 | assert(Curve_sampling.P2.to_list s = out_p2); 12 | #if OCAML_VERSION >= (4, 7, 0) 13 | assert(let l = List.of_seq (Curve_sampling.to_seq s) in 14 | List.map List.of_seq l = out); 15 | assert(List.of_seq (Curve_sampling.P2.to_seq s) = out_p2) 16 | #endif 17 | ;; 18 | 19 | let () = 20 | let s = Curve_sampling.of_path [(1.,nan); (2.,2.); (3., 3.); (nan,4.)] in 21 | let out = [ [(2.,2.); (3.,3.)] ] in 22 | let out_p2 = [point 2. 2.; point 3. 3.] in 23 | assert(Curve_sampling.to_list s = out); 24 | assert(Curve_sampling.P2.to_list s = out_p2); 25 | #if OCAML_VERSION >= (4, 7, 0) 26 | assert(let l = List.of_seq (Curve_sampling.to_seq s) in 27 | List.map List.of_seq l = out); 28 | assert(List.of_seq (Curve_sampling.P2.to_seq s) = out_p2) 29 | #endif 30 | ;; 31 | 32 | let () = 33 | let s = Curve_sampling.of_path 34 | [(1.,nan); (2.,2.); (3., 3.); (nan,4.); (5., nan); 35 | (6., 6.); (nan, 7.)] in 36 | let out = [ [(2.,2.); (3.,3.)]; [(6., 6.)] ] in 37 | let out_p2 = [point 2. 2.; point 3. 3.; Curve_sampling.P2.Cut; 38 | point 6. 6.] in 39 | assert(Curve_sampling.to_list s = out); 40 | assert(Curve_sampling.P2.to_list s = out_p2); 41 | #if OCAML_VERSION >= (4, 7, 0) 42 | assert(let l = List.of_seq (Curve_sampling.to_seq s) in 43 | List.map List.of_seq l = out); 44 | assert(List.of_seq (Curve_sampling.P2.to_seq s) = out_p2) 45 | #endif 46 | ;; 47 | --------------------------------------------------------------------------------