pax_global_header 0000666 0000000 0000000 00000000064 13060465153 0014515 g ustar 00root root 0000000 0000000 52 comment=1cc8f765d1598a545b67b03d8d0a7bfe4a65572e
mlpost-0.8.2/ 0000775 0000000 0000000 00000000000 13060465153 0013042 5 ustar 00root root 0000000 0000000 mlpost-0.8.2/.bzrignore 0000664 0000000 0000000 00000001036 13060465153 0015044 0 ustar 00root root 0000000 0000000 test/*tex
test/*mp
test/*mpx
test/*log
test/*aux
test/*dvi
test/*ps
test/tests.[0-9]*
test/othergraphs.[0-9]*
test/testmanual.[0-9]*
examples/*tex
examples/*mp
examples/*mpx
examples/*log
examples/*aux
examples/*dvi
examples/*ps
examples/*cm[io]
examples/*.ml.html
examples/*png
examples/index.html
test/manual/*log
test/manual/*mpx
test/manual/*.[0-9]*
test/othergraphs/*log
test/othergraphs/*mpx
test/othergraphs/*.[0-9]*
*.cm[oxia]
*.cmxa
*.annot
tool.ml
*.opt
version.ml
config.log
config.status
configure
Makefile
.depend
autom4te.cache
mlpost-0.8.2/.gitignore 0000664 0000000 0000000 00000001025 13060465153 0015030 0 ustar 00root root 0000000 0000000 META
Makefile
_build/
_build_dot
_build_lablgtk
autom4te.cache/
config.log
config.status
configure
mlpost.mli
myocamlbuild.ml
ocamlbuild.Makefile
simple.Makefile
version.ml
doc
examples/*.mps
test/*.mps
test/*.mp
test/*.ps
test/*.mpx
test/*.tex
test/*.log
test/*.aux
test/*.pdf
test/*.dvi
test/*.[0-9]*
test/othergraphs/*.[0-9]*
test/othergraphs/*.mpx
test/othergraphs/*.mps
test/othergraphs/*.log
test/manual/*.[0-9]*
test/manual/*.mpx
test/manual/*.mps
test/manual/*.log
www/*.html
www/version.prehtml
*.native
\#*\#
.#*
_mlpost.*
mlpost-0.8.2/AUTHORS 0000664 0000000 0000000 00000000251 13060465153 0014110 0 ustar 00root root 0000000 0000000 Main Developers:
Jean-Christophe Filliâtre
Johannes Kanig
Stéphane Lescuyer
Contributors:
Romain Bardou
Claude Marché
Florence Plateau
François Bobot
mlpost-0.8.2/CHANGES 0000664 0000000 0000000 00000014427 13060465153 0014045 0 ustar 00root root 0000000 0000000 o - changes in behaviour, new features, bugfixes
* - incompatible changes in the interface
version 0.8.2, March 10, 2017
-----------------------------
o mlpost does not complain anymore about Metapost errors
o ocamlopt is called with warning 58 disabled
o fixed installation with OCaml 4.04
o new module [Triangle] to draw tree-like, triangular shapes
* (internal) Misc.call_cmd now does print output of the called program
directly, instead of returning it as a string
* module Generate has been removed
version 0.8.1, April 26th 2010
------------------------------
o configure: store absolute paths of programs
o configure: fixed META file
o doc: documentation for contribs
o contrib lablgtk: background setting possible and function auto_aspect
version 0.8.0, April 13th, 2010
-------------------------------
* ocaml >= 3.10.1 is required now
* externalimage work only with png image
* module Color: the definitions of the following colors have changed:
lightblue, green, lightgreen, orange, lightcyan, purple, lightyellow
These colors are now compatible to HTML/CSS and X11 definitions
* Box: Box.tabularl did modify the input boxes, now it leaves them unchanged
(reported by Julien Signoles)
o contrib Mlpost_lablgtk : define a gtk widget to display mlpost figures
It also allow to easily create an interface to interact with an mlpost figures
o contrib Mlpost_dot : Use graphviz (dot) to place picture, box, ...
make contrib && make install-contrib
mlpost -contrib dot [...]
o module Real_plot: Plot function from float to float. It can use logarithmic
scale.
o module Color: new function hsv to create a color from hsv colorspace and
color_gen to generate different colors using hsv colorspace
o concrete computations are now available without the Cairo library
o option -ps with -cairo
o adding Concrete.baseline
o Num: new units em, ex
o Bugfix: "make install" with ocamlfind (reported by Julien Signoles)
o Bugfix: Concrete does not complain about being unsupported for the following
functions: set_verbosity; set_prelude, set_prelude2, set_t1disasm
o Bugfix: Don't use "tracingchoices"
o Bugfix #411: correct definition of objects used in Path.subpath
o metapost errors are printed (this should rarely occur)
o each call of mpost are done in separate and temporary directories
version 0.7.4, October 20th, 2009
--------------------------------
o Mlpost tool : Fix compilation with ocamlbuild
version 0.7.3, October 13th, 2009
--------------------------------
o Fix installation without ocamlfind and without ocamlbuild
version 0.7.2, October 9th, 2009
--------------------------------
* -classic-display is not an option of mlpost tool anymore (use -v instead)
* Change in the signature of Cairost.emit_cairo
o Fix the -compile-name option with ocamlbuild
o ocamlfind remove/install is used if ocamlfind is present
o The backend Concrete output informations only with the verbose option
o Radar: fixed size of bullets
o Helpers: the functions for boxes have a new optional argument [within] to
give a box in which the arguments will be searched
o Box: new functions [set_{post,pre}_draw]
* Box: [get_name] now returns a string option
o Tree.Simple: alignment options for [node]
o Box: optional argument dash
version 0.7.1, July 24th, 2009
------------------------------
o Fix for Performance bug when shifting boxes
version 0.7, July 23rd, 2009
----------------------------
* add Point.draw and Path.draw (alias of Command.draw) which can mask
Command.draw in case of an open Point after an open Command
* Command.draw_arrow becomes Arrow.simple
* Arrow.draw: ~pos becomes ~anchor, new ~pos is point on path
* Arrow.draw: now gives the same result by default as Arrow.simple (former
Command.draw_arrow)
* Arrow.draw2 becomes Arrow.point_to_point
* Mlpost tool: -pdf now the default; use -ps to produce .1 files
* Mlpost tool: erases all generated intermediate files on success
o New experimental backend using Cairo; it permits output in PS, PDF, SVG and
X11; use it with commandline option -cairo. It is intended to deliver the
same results as the old metapost backend. Please send a bug report if it is
not the case
o A module Concrete which permits to compute concrete values of mlpost
objects, e.g. the float value corresponding to an object of type Num.t ,
the concrete point { x : float; y : float } corresponding to a Point.t, and
so on
o A better tree drawing algorithm (module Tree)
o new function Tree.nodel to add labels to tree edges
o "Smart" paths to construct a path by giving only a sequence of directions
(module Path)
o Histograms and Radar diagrams (modules Hist and Radar)
o The type Picture.t now is equal to the type Command.t
(no more conversion needed)
o module Box: each box has a name by default; use Box.sub to retrieve a box
with the same name inside another
o New optional argument sep of Path.strip to strip both ends of a path; used
in Tree, Box.cpath, and Helpers
o New position constructors `North, `South, `Upperleft to improve upon `Top, `Bot
etc, but the old variants are still there
version 0.6, February 4th, 2009
-------------------------------
* "open Mlpost" is not added to input files any more -
users have to add by themselves
* the type Command.figure becomes Command.t
o inclusion of external images (png, jpg etc)
o transformations on boxes
o Box.{grid,gridl,gridi}: new options hpadding, vpadding, stroke, pen
o additional options for many functions
o corrections of some small bugs in box calculations
o A function in the API to scan a TeX file for the prelude
version 0.5, Octobre 20, 2008 (first public release)
----------------------------------------------------
o new option -native to use native compilation, useful for complicated pictures
version 0.3
-----------
o new module Pos to place lists, arrays, trees
* Num.f function removed
o new commandline arguments -v, -eps
* The functions in the Shapes module now build objects of type Shapes.t
instead of Path.t
* In Diag, one can now specify more (and different) types of boxes for nodes
version 0.2, July 22nd, 2008
----------------------------
o Box: no more use of boxes.mp, replaced by Ocaml code
o License: LGPL updated to version 2.1
o Num: t is now an abstract datatype
o Moved repository to a trunk/branches style
o Subversion repository updated to schema version 5
version 0.1
-----------
o first release of Mlpost
mlpost-0.8.2/FAQ 0000664 0000000 0000000 00000003213 13060465153 0013373 0 ustar 00root root 0000000 0000000 Frequently Asked Questions about Mlpost
------------------------------------------------------------------------------
1) When I run the mlpost tool on my figure, I get the error "! Unable to make
mpx file.".
Answer:
This is a cryptical error message from metapost saying that there is some
error in the Latex code that is part of your figure. However, it often points
to some random Latex code, so you will have to figure out the problem by
yourself, or by looking at the "mpxerr.tex" file that has been generated. You
can also try to pass the "mpxerr.tex" file to latex to see which is the exact
latex error message.
------------------------------------------------------------------------------
2) When I look at generated "foo.1" or "foo.mps" file, gv/evince does
not display the figure correctly / gives some error.
Answer:
These generated files are not proper PostScript files. They need to be
included in a Latex file using \includegraphics. If you pass the -eps option
to mlpost, it generates encapsulated PostScript files that can be viewed with
a PostScript viewer like gv. However, font rendering may be quite different.
------------------------------------------------------------------------------
3) In my Latex prelude I include other Latex files using "\input{foo.tex}".
When I compile my figure with mlpost, these files are not found.
You are probably compiling your figure and your Latex file in different
directories. You can make the file "foo.tex" visible to Latex changing the
environment variable $TEXINPUTS to contain the directory where "foo.tex"
lives.
------------------------------------------------------------------------------
mlpost-0.8.2/INSTALL 0000664 0000000 0000000 00000003536 13060465153 0014102 0 ustar 00root root 0000000 0000000 Dependencies:
* You need OCaml 4.0 or higher to compile Mlpost.
* You need Ocamlfind
* You need the libraries bitstring, lablgtk2 and cairo for cairo support.
Check the output of ./configure to see if cairo has been selected.
* To use Mlpost, you need metapost and metafun (packages texlive-metapost and
context in debian) if you don't use the -mps option.
* For the html version of the examples, you need caml2html, version 1.3.0 or
higher.
* One example needs the tex chess fonts to work (package tex-chess in debian)
* For external images, you need imagemagick
* For the contrib package Mlpost_dot you need Objective Caml 3.10.2 or higher
and dot (graphviz) at runtime
1. Configure with
./configure
If you want to specify the directory where libraries (cmi, cma, ...) will be
installed:
./configure LIBDIR=/your/libdir
If you want to specify the directory where the binary (mlpost) will be installed:
./configure --bindir=/your/bindir
2. Compile with
make
3. Install (as root) with
make install
It installs the library in Ocaml's standard library and the tool "mlpost"
in /usr/local/bin (or any other directory specified with ./configure --bindir).
4 (optional)
Compile the contrib librairies
make contrib
5 (optional)
Install the contrib librairies
make install-contrib
6 (optional)
copy the files from the latex subdirectory at a place where latex can find
it (see the README in that directory)
7 (optional). Create the documentation in doc/ with
make doc
and the examples in examples/ with
make -C examples
and (optional) the contrib examples after installing the contrib librairies
make -C examples contrib
To create html versions of the examples, you need caml2html version 1.3.0;
you can then issue
make -C examples html
mlpost-0.8.2/LICENSE 0000664 0000000 0000000 00000065616 13060465153 0014065 0 ustar 00root root 0000000 0000000 The Library is distributed under the terms of the GNU Library General
Public License version 2.1 (included below).
As a special exception to the GNU Library General Public License, you
may link, statically or dynamically, a "work that uses the Library"
with a publicly distributed version of the Library to produce an
executable file containing portions of the Library, and distribute
that executable file under terms of your choice, without any of the
additional requirements listed in clause 6 of the GNU Library General
Public License. By "a publicly distributed version of the Library", we
mean either the unmodified Library as distributed, or a
modified version of the Library that is distributed under the
conditions defined in clause 3 of the GNU Library General Public
License. This exception does not however invalidate any other reasons
why the executable file might be covered by the GNU Library General
Public License.
======================================================================
GNU LESSER GENERAL PUBLIC LICENSE
Version 2.1, February 1999
Copyright (C) 1991, 1999 Free Software Foundation, Inc.
51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
Everyone is permitted to copy and distribute verbatim copies
of this license document, but changing it is not allowed.
[This is the first released version of the Lesser GPL. It also counts
as the successor of the GNU Library Public License, version 2, hence
the version number 2.1.]
Preamble
The licenses for most software are designed to take away your
freedom to share and change it. By contrast, the GNU General Public
Licenses are intended to guarantee your freedom to share and change
free software--to make sure the software is free for all its users.
This license, the Lesser General Public License, applies to some
specially designated software packages--typically libraries--of the
Free Software Foundation and other authors who decide to use it. You
can use it too, but we suggest you first think carefully about whether
this license or the ordinary General Public License is the better
strategy to use in any particular case, based on the explanations
below.
When we speak of free software, we are referring to freedom of use,
not price. Our General Public Licenses are designed to make sure that
you have the freedom to distribute copies of free software (and charge
for this service if you wish); that you receive source code or can get
it if you want it; that you can change the software and use pieces of
it in new free programs; and that you are informed that you can do
these things.
To protect your rights, we need to make restrictions that forbid
distributors to deny you these rights or to ask you to surrender these
rights. These restrictions translate to certain responsibilities for
you if you distribute copies of the library or if you modify it.
For example, if you distribute copies of the library, whether gratis
or for a fee, you must give the recipients all the rights that we gave
you. You must make sure that they, too, receive or can get the source
code. If you link other code with the library, you must provide
complete object files to the recipients, so that they can relink them
with the library after making changes to the library and recompiling
it. And you must show them these terms so they know their rights.
We protect your rights with a two-step method: (1) we copyright the
library, and (2) we offer you this license, which gives you legal
permission to copy, distribute and/or modify the library.
To protect each distributor, we want to make it very clear that
there is no warranty for the free library. Also, if the library is
modified by someone else and passed on, the recipients should know
that what they have is not the original version, so that the original
author's reputation will not be affected by problems that might be
introduced by others.
Finally, software patents pose a constant threat to the existence of
any free program. We wish to make sure that a company cannot
effectively restrict the users of a free program by obtaining a
restrictive license from a patent holder. Therefore, we insist that
any patent license obtained for a version of the library must be
consistent with the full freedom of use specified in this license.
Most GNU software, including some libraries, is covered by the
ordinary GNU General Public License. This license, the GNU Lesser
General Public License, applies to certain designated libraries, and
is quite different from the ordinary General Public License. We use
this license for certain libraries in order to permit linking those
libraries into non-free programs.
When a program is linked with a library, whether statically or using
a shared library, the combination of the two is legally speaking a
combined work, a derivative of the original library. The ordinary
General Public License therefore permits such linking only if the
entire combination fits its criteria of freedom. The Lesser General
Public License permits more lax criteria for linking other code with
the library.
We call this license the "Lesser" General Public License because it
does Less to protect the user's freedom than the ordinary General
Public License. It also provides other free software developers Less
of an advantage over competing non-free programs. These disadvantages
are the reason we use the ordinary General Public License for many
libraries. However, the Lesser license provides advantages in certain
special circumstances.
For example, on rare occasions, there may be a special need to
encourage the widest possible use of a certain library, so that it
becomes a de-facto standard. To achieve this, non-free programs must
be allowed to use the library. A more frequent case is that a free
library does the same job as widely used non-free libraries. In this
case, there is little to gain by limiting the free library to free
software only, so we use the Lesser General Public License.
In other cases, permission to use a particular library in non-free
programs enables a greater number of people to use a large body of
free software. For example, permission to use the GNU C Library in
non-free programs enables many more people to use the whole GNU
operating system, as well as its variant, the GNU/Linux operating
system.
Although the Lesser General Public License is Less protective of the
users' freedom, it does ensure that the user of a program that is
linked with the Library has the freedom and the wherewithal to run
that program using a modified version of the Library.
The precise terms and conditions for copying, distribution and
modification follow. Pay close attention to the difference between a
"work based on the library" and a "work that uses the library". The
former contains code derived from the library, whereas the latter must
be combined with the library in order to run.
GNU LESSER GENERAL PUBLIC LICENSE
TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
0. This License Agreement applies to any software library or other
program which contains a notice placed by the copyright holder or
other authorized party saying it may be distributed under the terms of
this Lesser General Public License (also called "this License").
Each licensee is addressed as "you".
A "library" means a collection of software functions and/or data
prepared so as to be conveniently linked with application programs
(which use some of those functions and data) to form executables.
The "Library", below, refers to any such software library or work
which has been distributed under these terms. A "work based on the
Library" means either the Library or any derivative work under
copyright law: that is to say, a work containing the Library or a
portion of it, either verbatim or with modifications and/or translated
straightforwardly into another language. (Hereinafter, translation is
included without limitation in the term "modification".)
"Source code" for a work means the preferred form of the work for
making modifications to it. For a library, complete source code means
all the source code for all modules it contains, plus any associated
interface definition files, plus the scripts used to control
compilation and installation of the library.
Activities other than copying, distribution and modification are not
covered by this License; they are outside its scope. The act of
running a program using the Library is not restricted, and output from
such a program is covered only if its contents constitute a work based
on the Library (independent of the use of the Library in a tool for
writing it). Whether that is true depends on what the Library does
and what the program that uses the Library does.
1. You may copy and distribute verbatim copies of the Library's
complete source code as you receive it, in any medium, provided that
you conspicuously and appropriately publish on each copy an
appropriate copyright notice and disclaimer of warranty; keep intact
all the notices that refer to this License and to the absence of any
warranty; and distribute a copy of this License along with the
Library.
You may charge a fee for the physical act of transferring a copy,
and you may at your option offer warranty protection in exchange for a
fee.
2. You may modify your copy or copies of the Library or any portion
of it, thus forming a work based on the Library, and copy and
distribute such modifications or work under the terms of Section 1
above, provided that you also meet all of these conditions:
a) The modified work must itself be a software library.
b) You must cause the files modified to carry prominent notices
stating that you changed the files and the date of any change.
c) You must cause the whole of the work to be licensed at no
charge to all third parties under the terms of this License.
d) If a facility in the modified Library refers to a function or a
table of data to be supplied by an application program that uses
the facility, other than as an argument passed when the facility
is invoked, then you must make a good faith effort to ensure that,
in the event an application does not supply such function or
table, the facility still operates, and performs whatever part of
its purpose remains meaningful.
(For example, a function in a library to compute square roots has
a purpose that is entirely well-defined independent of the
application. Therefore, Subsection 2d requires that any
application-supplied function or table used by this function must
be optional: if the application does not supply it, the square
root function must still compute square roots.)
These requirements apply to the modified work as a whole. If
identifiable sections of that work are not derived from the Library,
and can be reasonably considered independent and separate works in
themselves, then this License, and its terms, do not apply to those
sections when you distribute them as separate works. But when you
distribute the same sections as part of a whole which is a work based
on the Library, the distribution of the whole must be on the terms of
this License, whose permissions for other licensees extend to the
entire whole, and thus to each and every part regardless of who wrote
it.
Thus, it is not the intent of this section to claim rights or contest
your rights to work written entirely by you; rather, the intent is to
exercise the right to control the distribution of derivative or
collective works based on the Library.
In addition, mere aggregation of another work not based on the Library
with the Library (or with a work based on the Library) on a volume of
a storage or distribution medium does not bring the other work under
the scope of this License.
3. You may opt to apply the terms of the ordinary GNU General Public
License instead of this License to a given copy of the Library. To do
this, you must alter all the notices that refer to this License, so
that they refer to the ordinary GNU General Public License, version 2,
instead of to this License. (If a newer version than version 2 of the
ordinary GNU General Public License has appeared, then you can specify
that version instead if you wish.) Do not make any other change in
these notices.
Once this change is made in a given copy, it is irreversible for
that copy, so the ordinary GNU General Public License applies to all
subsequent copies and derivative works made from that copy.
This option is useful when you wish to copy part of the code of
the Library into a program that is not a library.
4. You may copy and distribute the Library (or a portion or
derivative of it, under Section 2) in object code or executable form
under the terms of Sections 1 and 2 above provided that you accompany
it with the complete corresponding machine-readable source code, which
must be distributed under the terms of Sections 1 and 2 above on a
medium customarily used for software interchange.
If distribution of object code is made by offering access to copy
from a designated place, then offering equivalent access to copy the
source code from the same place satisfies the requirement to
distribute the source code, even though third parties are not
compelled to copy the source along with the object code.
5. A program that contains no derivative of any portion of the
Library, but is designed to work with the Library by being compiled or
linked with it, is called a "work that uses the Library". Such a
work, in isolation, is not a derivative work of the Library, and
therefore falls outside the scope of this License.
However, linking a "work that uses the Library" with the Library
creates an executable that is a derivative of the Library (because it
contains portions of the Library), rather than a "work that uses the
library". The executable is therefore covered by this License.
Section 6 states terms for distribution of such executables.
When a "work that uses the Library" uses material from a header file
that is part of the Library, the object code for the work may be a
derivative work of the Library even though the source code is not.
Whether this is true is especially significant if the work can be
linked without the Library, or if the work is itself a library. The
threshold for this to be true is not precisely defined by law.
If such an object file uses only numerical parameters, data
structure layouts and accessors, and small macros and small inline
functions (ten lines or less in length), then the use of the object
file is unrestricted, regardless of whether it is legally a derivative
work. (Executables containing this object code plus portions of the
Library will still fall under Section 6.)
Otherwise, if the work is a derivative of the Library, you may
distribute the object code for the work under the terms of Section 6.
Any executables containing that work also fall under Section 6,
whether or not they are linked directly with the Library itself.
6. As an exception to the Sections above, you may also combine or
link a "work that uses the Library" with the Library to produce a
work containing portions of the Library, and distribute that work
under terms of your choice, provided that the terms permit
modification of the work for the customer's own use and reverse
engineering for debugging such modifications.
You must give prominent notice with each copy of the work that the
Library is used in it and that the Library and its use are covered by
this License. You must supply a copy of this License. If the work
during execution displays copyright notices, you must include the
copyright notice for the Library among them, as well as a reference
directing the user to the copy of this License. Also, you must do one
of these things:
a) Accompany the work with the complete corresponding
machine-readable source code for the Library including whatever
changes were used in the work (which must be distributed under
Sections 1 and 2 above); and, if the work is an executable linked
with the Library, with the complete machine-readable "work that
uses the Library", as object code and/or source code, so that the
user can modify the Library and then relink to produce a modified
executable containing the modified Library. (It is understood
that the user who changes the contents of definitions files in the
Library will not necessarily be able to recompile the application
to use the modified definitions.)
b) Use a suitable shared library mechanism for linking with the
Library. A suitable mechanism is one that (1) uses at run time a
copy of the library already present on the user's computer system,
rather than copying library functions into the executable, and (2)
will operate properly with a modified version of the library, if
the user installs one, as long as the modified version is
interface-compatible with the version that the work was made with.
c) Accompany the work with a written offer, valid for at least
three years, to give the same user the materials specified in
Subsection 6a, above, for a charge no more than the cost of
performing this distribution.
d) If distribution of the work is made by offering access to copy
from a designated place, offer equivalent access to copy the above
specified materials from the same place.
e) Verify that the user has already received a copy of these
materials or that you have already sent this user a copy.
For an executable, the required form of the "work that uses the
Library" must include any data and utility programs needed for
reproducing the executable from it. However, as a special exception,
the materials to be distributed need not include anything that is
normally distributed (in either source or binary form) with the major
components (compiler, kernel, and so on) of the operating system on
which the executable runs, unless that component itself accompanies
the executable.
It may happen that this requirement contradicts the license
restrictions of other proprietary libraries that do not normally
accompany the operating system. Such a contradiction means you cannot
use both them and the Library together in an executable that you
distribute.
7. You may place library facilities that are a work based on the
Library side-by-side in a single library together with other library
facilities not covered by this License, and distribute such a combined
library, provided that the separate distribution of the work based on
the Library and of the other library facilities is otherwise
permitted, and provided that you do these two things:
a) Accompany the combined library with a copy of the same work
based on the Library, uncombined with any other library
facilities. This must be distributed under the terms of the
Sections above.
b) Give prominent notice with the combined library of the fact
that part of it is a work based on the Library, and explaining
where to find the accompanying uncombined form of the same work.
8. You may not copy, modify, sublicense, link with, or distribute
the Library except as expressly provided under this License. Any
attempt otherwise to copy, modify, sublicense, link with, or
distribute the Library is void, and will automatically terminate your
rights under this License. However, parties who have received copies,
or rights, from you under this License will not have their licenses
terminated so long as such parties remain in full compliance.
9. You are not required to accept this License, since you have not
signed it. However, nothing else grants you permission to modify or
distribute the Library or its derivative works. These actions are
prohibited by law if you do not accept this License. Therefore, by
modifying or distributing the Library (or any work based on the
Library), you indicate your acceptance of this License to do so, and
all its terms and conditions for copying, distributing or modifying
the Library or works based on it.
10. Each time you redistribute the Library (or any work based on the
Library), the recipient automatically receives a license from the
original licensor to copy, distribute, link with or modify the Library
subject to these terms and conditions. You may not impose any further
restrictions on the recipients' exercise of the rights granted herein.
You are not responsible for enforcing compliance by third parties with
this License.
11. If, as a consequence of a court judgment or allegation of patent
infringement or for any other reason (not limited to patent issues),
conditions are imposed on you (whether by court order, agreement or
otherwise) that contradict the conditions of this License, they do not
excuse you from the conditions of this License. If you cannot
distribute so as to satisfy simultaneously your obligations under this
License and any other pertinent obligations, then as a consequence you
may not distribute the Library at all. For example, if a patent
license would not permit royalty-free redistribution of the Library by
all those who receive copies directly or indirectly through you, then
the only way you could satisfy both it and this License would be to
refrain entirely from distribution of the Library.
If any portion of this section is held invalid or unenforceable under
any particular circumstance, the balance of the section is intended to
apply, and the section as a whole is intended to apply in other
circumstances.
It is not the purpose of this section to induce you to infringe any
patents or other property right claims or to contest validity of any
such claims; this section has the sole purpose of protecting the
integrity of the free software distribution system which is
implemented by public license practices. Many people have made
generous contributions to the wide range of software distributed
through that system in reliance on consistent application of that
system; it is up to the author/donor to decide if he or she is willing
to distribute software through any other system and a licensee cannot
impose that choice.
This section is intended to make thoroughly clear what is believed to
be a consequence of the rest of this License.
12. If the distribution and/or use of the Library is restricted in
certain countries either by patents or by copyrighted interfaces, the
original copyright holder who places the Library under this License
may add an explicit geographical distribution limitation excluding those
countries, so that distribution is permitted only in or among
countries not thus excluded. In such case, this License incorporates
the limitation as if written in the body of this License.
13. The Free Software Foundation may publish revised and/or new
versions of the Lesser General Public License from time to time.
Such new versions will be similar in spirit to the present version,
but may differ in detail to address new problems or concerns.
Each version is given a distinguishing version number. If the Library
specifies a version number of this License which applies to it and
"any later version", you have the option of following the terms and
conditions either of that version or of any later version published by
the Free Software Foundation. If the Library does not specify a
license version number, you may choose any version ever published by
the Free Software Foundation.
14. If you wish to incorporate parts of the Library into other free
programs whose distribution conditions are incompatible with these,
write to the author to ask for permission. For software which is
copyrighted by the Free Software Foundation, write to the Free
Software Foundation; we sometimes make exceptions for this. Our
decision will be guided by the two goals of preserving the free status
of all derivatives of our free software and of promoting the sharing
and reuse of software generally.
NO WARRANTY
15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO
WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW.
EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR
OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY
KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE
IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE
LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME
THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN
WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY
AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU
FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR
CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE
LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH
DAMAGES.
END OF TERMS AND CONDITIONS
How to Apply These Terms to Your New Libraries
If you develop a new library, and you want it to be of the greatest
possible use to the public, we recommend making it free software that
everyone can redistribute and change. You can do so by permitting
redistribution under these terms (or, alternatively, under the terms
of the ordinary General Public License).
To apply these terms, attach the following notices to the library.
It is safest to attach them to the start of each source file to most
effectively convey the exclusion of warranty; and each file should
have at least the "copyright" line and a pointer to where the full
notice is found.
Copyright (C)
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.
This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
Also add information on how to contact you by electronic and paper mail.
You should also get your employer (if you work as a programmer) or
your school, if any, to sign a "copyright disclaimer" for the library,
if necessary. Here is a sample; alter the names:
Yoyodyne, Inc., hereby disclaims all copyright interest in the
library `Frob' (a library for tweaking knobs) written by James
Random Hacker.
, 1 April 1990
Ty Coon, President of Vice
That's all there is to it!
mlpost-0.8.2/META.in 0000664 0000000 0000000 00000000563 13060465153 0014124 0 ustar 00root root 0000000 0000000 description = "OCaml interface to Mlpost"
version = "@PACKAGE_VERSION@"
archive(byte) = "mlpost.cma"
archive(native) = "mlpost.cmxa"
requires = "@METAREQUIRESPACKAGE@"
package "options" (
version = "@PACKAGE_VERSION@"
requires = "mlpost"
archive(byte) = "mlpost_desc_options.cma mlpost_options.cma"
archive(native) = "mlpost_desc_options.cmxa mlpost_options.cmxa"
)
mlpost-0.8.2/Makefile.in 0000664 0000000 0000000 00000020515 13060465153 0015112 0 ustar 00root root 0000000 0000000 ##########################################################################
# #
# Copyright (C) Johannes Kanig, Stephane Lescuyer #
# Jean-Christophe Filliatre, Romain Bardou and Francois Bobot #
# #
# This software is free software; you can redistribute it and/or #
# modify it under the terms of the GNU Library General Public #
# License version 2.1, with the special exception on linking #
# described in file LICENSE. #
# #
# This software is distributed in the hope that it will be useful, #
# but WITHOUT ANY WARRANTY; without even the implied warranty of #
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. #
# #
##########################################################################
#common variables set by configure script
############################################
# where to install the binaries
prefix=@prefix@
datarootdir = @datarootdir@
datadir = @datadir@
exec_prefix=@exec_prefix@
BINDIR=@bindir@
LIBDIR=@LIBDIR@
OCAMLFIND=@OCAMLFIND@
OCAMLBUILDBIN=@OCAMLBUILD@
# where to install the man page
MANDIR=@mandir@
PSVIEWER=@PSVIEWER@
PDFVIEWER=@PDFVIEWER@
# other variables set by ./configure
OCAMLC = @OCAMLC@
OCAMLOPT = @OCAMLOPT@
OCAMLDEP = @OCAMLDEP@
OCAMLLEX = @OCAMLLEX@
OCAMLYACC= @OCAMLYACC@
#(not used) OCAMLLIB = @OCAMLLIB@
OCAMLBEST= @OCAMLBEST@
OCAMLVERSION = @OCAMLVERSION@
OCAMLWEB = @OCAMLWEB@
OCAMLWIN32 = @OCAMLWIN32@
EXE = @EXE@
LIBEXT = @LIBEXT@
OBJEXT = @OBJEXT@
TAGS = @TAGS@
INCLUDES = -I gui -I +threads @INCLUDEGTK2@
BFLAGS = -dtypes $(INCLUDES)
OFLAGS = -g -dtypes $(INCLUDES) -for-pack Mlpost
LABLGTK2 = @LABLGTK2@
LABLGTK2LIB = @LABLGTK2LIB@
CAIROLABLGTK2 = @CAIROLABLGTK2@
CAIROLABLGTK2LIB = @CAIROLABLGTK2LIB@
# main target
#############
NAME = mlpost
MLPOSTVERSION=@PACKAGE_VERSION@
# decide which Makefile to use
include ocamlbuild.Makefile
# common part of both Makefiles
##################################
# misc
######
dep:
$(OCAMLDEP) *.mli *.ml | ocamldot | dot -Tps | $(PSVIEWER) -
wc:
ocamlwc *.ml* backend/*.ml* -p
man:
nroff -Tascii -mandoc mlpost.1 | less
# headers
#########
headers:
headache -c headache_config.txt -h header.txt \
*.in README.txt *.mli *.ml *.mll backend/*.ml backend/*.ml[iyl]
./config.status
# installation
##############
install: install-$(OCAMLBEST) install-bin
install-contrib : install-$(OCAMLBEST)-contrib
install-byte-contrib: install-byte-dot install-byte-lablgtk
install-opt-contrib: install-opt-dot install-opt-lablgtk
BCMA = $(addprefix $(BUILD), $(CMA) $(DLL))
BCMXA = $(addprefix $(BUILD), $(CMXA) $(OBJ))
BCMT = $(addprefix $(BUILD), mlpost.cmti mlpost.cmt)
DESTDIR=-destdir $(LIBDIR:/mlpost=)
install-byte:
$(OCAMLFIND) remove $(DESTDIR) mlpost
$(OCAMLFIND) install $(DESTDIR) mlpost $(BUILD)mlpost.cmi META $(BCMA) $(BCMT)
install-opt:
$(OCAMLFIND) remove $(DESTDIR) mlpost
$(OCAMLFIND) install $(DESTDIR) mlpost $(BUILD)mlpost$(LIBEXT) $(BUILD)mlpost.cmi META $(BCMXA) $(BCMA) $(BCMT)
install-byte-dot:
$(OCAMLFIND) remove $(DESTDIR) mlpost_dot
$(OCAMLFIND) install $(DESTDIR) mlpost_dot contrib/dot/META \
$(addprefix contrib/dot/_build/mlpost_dot,.cmi .cma .cmt .cmti)
install-opt-dot:
$(OCAMLFIND) remove $(DESTDIR) mlpost_dot
$(OCAMLFIND) install $(DESTDIR) mlpost_dot contrib/dot/META \
$(addprefix contrib/dot/_build/mlpost_dot,.cmi .cma .cmxa $(LIBEXT) .cmt .cmti)
ifeq "$(LABLGTK2)$(CAIROLABLGTK2)" "yesyes"
install-byte-lablgtk:
$(OCAMLFIND) remove $(DESTDIR) mlpost_lablgtk
$(OCAMLFIND) install $(DESTDIR) mlpost_lablgtk contrib/lablgtk/META \
$(addprefix contrib/lablgtk/_build/mlpost_lablgtk,.cmi .cma .cmt .cmti)
install-opt-lablgtk:
$(OCAMLFIND) remove $(DESTDIR) mlpost_lablgtk
$(OCAMLFIND) install $(DESTDIR) mlpost_lablgtk contrib/lablgtk/META \
$(addprefix contrib/lablgtk/_build/mlpost_lablgtk,.cmi .cma .cmxa $(LIBEXT) .cmt .cmti)
else
install-byte-lablgtk:
install-opt-lablgtk:
endif
install-byte-contrib: install-byte-dot install-byte-lablgtk
install-bin:
mkdir -p $(BINDIR) $(MANDIR)/man1
cp -f $(BUILD)$(TOOL) $(BINDIR)/mlpost
cp -f mlpost.1 $(MANDIR)/man1
uninstall: uninstall-contrib
$(OCAMLFIND) remove $(DESTDIR) mlpost
rm -f $(BINDIR)/mlpost
rm -f $(MANDIR)/mlpost
uninstall-contrib:
$(OCAMLFIND) remove $(DESTDIR) mlpost_dot
$(OCAMLFIND) remove $(DESTDIR) mlpost_lablgtk
# export
########
EXPORTDIR=$(NAME)-$(MLPOSTVERSION)
TAR=$(EXPORTDIR).tar
WWW = /users/www-perso/projets/mlpost
FTP = $(WWW)/download
FILES := $(wildcard *.ml) $(wildcard *.mli) $(wildcard *.mll) \
$(wildcard *.in) configure README.txt INSTALL LICENSE CHANGES FAQ \
mlpost.1 _tags *.mlpack mlpost_yeslablgtk.odocl mlpost_nolablgtk.odocl ocamlbuild.Makefile
BACKENDFILES = backend/*ml backend/*mli backend/_tags
DVIFILES = dvi/*mly dvi/*mll dvi/*ml dvi/*mli dvi/_tags
CONCRETEFILES = concrete/*ml concrete/*mli concrete/_tags
GENERATEDSOURCEFILES = version.ml myocamlbuild.ml $(GENERATED)
GUIFILES = gui/*.mll gui/*.ml gui/_tags
EXFILES = examples/Makefile examples/*.ml examples/all.template\
examples/index.html examples/parse.mll examples/README\
examples/prototype.js examples/style.css \
examples/powered-by-caml.128x58.png
CONTRIBDOTFILES = $(addprefix contrib/dot/, dot.ml dot.mli Makefile META mlpost_dot.mli mlpost_dot.mlpack _tags xdot_ast.mli xdot_lexer.mll xdot_parser.mly)
CONTRIBLABLGTKFILES = $(addprefix contrib/lablgtk/, META mlpost_lablgtk.ml mlpost_lablgtk.mli)
CUSTOMDOCFILES = customdoc/all.template customdoc/img_doc.ml customdoc/img.ml \
customdoc/Makefile customdoc/_tags
LATEXFILES = latex/*sty latex/*tex latex/README
export: export-source export-www export-examples export-doc
cp README.txt INSTALL LICENSE CHANGES FAQ $(FTP)
export-source: source
cp export/$(TAR).gz $(FTP)
source:
mkdir -p export/$(EXPORTDIR)
cp $(filter-out $(GENERATEDSOURCEFILES), $(FILES)) export/$(EXPORTDIR)
mkdir -p export/$(EXPORTDIR)/backend
cp $(BACKENDFILES) export/$(EXPORTDIR)/backend
mkdir -p export/$(EXPORTDIR)/dvi
cp $(DVIFILES) export/$(EXPORTDIR)/dvi
mkdir -p export/$(EXPORTDIR)/concrete
cp $(CONCRETEFILES) export/$(EXPORTDIR)/concrete
mkdir -p export/$(EXPORTDIR)/gui
cp $(GUIFILES) export/$(EXPORTDIR)/gui
mkdir -p export/$(EXPORTDIR)/examples
cp $(EXFILES) export/$(EXPORTDIR)/examples
mkdir -p export/$(EXPORTDIR)/customdoc
cp $(CUSTOMDOCFILES) export/$(EXPORTDIR)/customdoc
mkdir -p export/$(EXPORTDIR)/latex
cp $(LATEXFILES) export/$(EXPORTDIR)/latex
mkdir -p export/$(EXPORTDIR)/contrib/dot
mkdir -p export/$(EXPORTDIR)/contrib/lablgtk
cp $(CONTRIBDOTFILES) export/$(EXPORTDIR)/contrib/dot
cp $(CONTRIBLABLGTKFILES) export/$(EXPORTDIR)/contrib/lablgtk
cd export ; tar cf $(TAR) $(EXPORTDIR) ; gzip -f --best $(TAR)
DOCFILES:=$(shell echo *.mli)
DOCFILES:=$(filter-out types.mli, $(DOCFILES))
export-doc: doc
mkdir -p $(WWW)/doc/img
cp doc/*.html doc/style.css $(WWW)/doc
cp doc/img/*.png $(WWW)/doc/img
export-www: www/version.prehtml
make -C www
www/version.prehtml: Makefile
echo "<#def version>$(MLPOSTVERSION)#def>" > www/version.prehtml
export-examples:
$(MAKEEXAMPLES)
cp -f --parents examples/*.png examples/*.html examples/*.svg examples/prototype.js examples/style.css $(WWW)
# Emacs tags
############
tags:
find . -name "*.ml*" | sort -r | xargs \
etags "--regex=/let[ \t]+\([^ \t]+\)/\1/" \
"--regex=/let[ \t]+rec[ \t]+\([^ \t]+\)/\1/" \
"--regex=/and[ \t]+\([^ \t]+\)/\1/" \
"--regex=/type[ \t]+\([^ \t]+\)/\1/" \
"--regex=/exception[ \t]+\([^ \t]+\)/\1/" \
"--regex=/val[ \t]+\([^ \t]+\)/\1/" \
"--regex=/module[ \t]+\([^ \t]+\)/\1/"
.PHONY: ocamlwizard
ocamlwizard:
ocamlrun -bt ocamlwizard compile types.mli $(CMO:.cmo=.ml) mlpost.mli
# Makefile is rebuilt whenever Makefile.in or configure.in is modified
######################################################################
Makefile META version.ml myocamlbuild.ml: Makefile.in META.in version.ml.in config.status myocamlbuild.ml.in
./config.status
chmod a-w myocamlbuild.ml META Makefile version.ml
config.status: configure
./config.status --recheck
configure: configure.in
autoconf
mlpost-0.8.2/README.txt 0000664 0000000 0000000 00000005352 13060465153 0014545 0 ustar 00root root 0000000 0000000 **************************************************************************
* *
* Copyright (C) Johannes Kanig, Stephane Lescuyer *
* Jean-Christophe Filliatre, Romain Bardou and Francois Bobot *
* *
* This software is free software; you can redistribute it and/or *
* modify it under the terms of the GNU Library General Public *
* License version 2.1, with the special exception on linking *
* described in file LICENSE. *
* *
* This software is distributed in the hope that it will be useful, *
* but WITHOUT ANY WARRANTY; without even the implied warranty of *
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *
* *
**************************************************************************
This is MLPost !
Usage:
------
* Open the Mlpost pack:
open Mlpost
* Define your figures in an Ocaml file fig.ml
let fig_a = ...
let fig_b = ...
Each figure has type Command.t.
* Add some code to emit Metapost code, as follows
let () = Metapost.emit "file_a" fig_a
let () = Metapost.emit "file_b" fig_b
* Then run the mlpost program on this file
mlpost fig.ml
It will create PostScript figures in files file_a.1, file_b.1, etc.
Options:
--------
mlpost supports the following options:
-pdf
creates .mps files instead of .1, for inclusion in LaTeX files
compiled with pdflatex (the PostScript file is actually the
same, but the suffix is used by pdflatex to identify
PostScript produced by Metapost)
-latex main.tex
indicates the main LaTeX file, from which the prelude is
extracted to be passed to Metapost (this way you can use
macros, fonts and packages from your LaTeX document in your
figures).
-xpdf
opens an xpdf viewer with the generated figure. Subsequent calls with
the option -xpdf will refresh the viewer, if it is still open.
-native
compile to native code. This is usually faster.
-eps
produce standalone postscript files
-ocamlbuild
use ocamlbuild to compile the source; this may be useful it there are
a lot of dependencies
-ccopt
pass options to the ocaml compiler
-execopt
pass options to the compiled program
Cairo output:
-------------
The following functions are not supported in combination with the Concrete /
Cairo modules:
* Path.build_cycle
* Pen.square
* Pen.from_path
mlpost-0.8.2/TODO 0000664 0000000 0000000 00000003066 13060465153 0013537 0 ustar 00root root 0000000 0000000 1) BUGS
(des erreurs ou des TODOs trs importantes)
==========
* installation des fichiers Latex pour inclusion d'images
* images et sortie postscript ?
* Probleme d'alignement avec slideshow + externalimage
2) TODO
(amliorer du comportement interne, doc, des bugs pas trs importants)
============
* ranger le module Helpers
* les fonctions de scale : pourquoi prennent-elles des Num.t, et non pas de
float ?
* Box.group, align etc prennent des listes, Box.elts renvoie un tableau ?
3) FEATURES
(choses qui n'existent pas encore dans mlpost)
===========================
* refaire Diag :
- pouvoir mettre n'importe quelle bote
- pouvoir choisir les flches
- interface fonctionelle
- le supprimer en fait ? indiquer "deprecated" au dessus ?
* Box :
- foncteur WithBox pour faciliter l'accs aux botes nommes
- clipping
* Arrow :
- rajouter draw_box_box, draw_point_box, draw_box_point ou d'autres noms
* fusionner Picture et Box ??
* TODO BACKEND
- build-cycle
- Transformations sur les pens
-------------------------------------------------------------------------------
des liens avec des exemples :
http://tex.loria.fr/prod-graph/zoonekynd/metapost/metapost.html
http://melusine.eu.org/syracuse/metapost/cheno/illustrations/illustrations.html
http://melusine.eu.org/syracuse/metapost/mpman/
http://www.cs.ucc.ie/~dongen/mpost/mpost.html
http://www.ursoswald.ch/metapost/tutorial.pdf
http://remote.science.uva.nl/~heck/Courses/mptut.pdf
(* ceci est metafun (metapost plus des macros) *)
http://www.pragma-ade.com/general/manuals/metafun-p.pdf
mlpost-0.8.2/_tags 0000664 0000000 0000000 00000001367 13060465153 0014071 0 ustar 00root root 0000000 0000000 <*.cmx> and not and not and not : for-pack(Mlpost)
: linkall
: pkg_cairo
or : pkg_cairo
: use_unix
: syntax_mymacroparser
or : syntax_macro
: use_unix, pkg_bitstring, pkg_cairo, use_cairo_bigarray
: use_unix, pkg_bitstring, pkg_cairo, use_cairo_bigarray
: use_unix, pkg_bitstring, pkg_cairo, use_cairo_bigarray
: include
: syntax_macro, pkg_cairo
: syntax_macro, pkg_cairo
: use_freetype, use_libmlpost_ft
: use_freetype, use_libmlpost_ft, pkg_cairo, I(backend)
mlpost-0.8.2/alphafill.mp 0000664 0000000 0000000 00000002442 13060465153 0015336 0 ustar 00root root 0000000 0000000 % taken from http://wwwmathlabo.univ-poitiers.fr/~phan/metalpha.html
%
picture alphapict_; alphapict_=nullpicture;
color fillcolor; fillcolor=red;
fgalpha := 0.5; % usual alpha parameter
bgalpha:= 1; % alpha parameter with respect to the background
vardef alphafill expr c =
alphapict_ := nullpicture;
alphafill_(currentpicture, c);
addto currentpicture also alphapict_;
enddef;
def alphafill_(expr p, c) =
begingroup
save p_, xmax_, xmin_, ymax_, ymin_; picture p_;
p_ = nullpicture;
(xmin_, ymin_) = llcorner c; (xmax_, ymax_) = urcorner c;
addto p_ contour c withcolor bgalpha[background, fillcolor];
for p__ within p:
numeric xmin__, xmax__, ymin__, ymax__;
(xmin__, ymin__) = llcorner p__; (xmax__, ymax__) = urcorner p__;
if (xmax__<= xmin_) or (xmin__ >= xmax_):
else:
if (ymax__<= ymin_) or (ymin__ >= ymax_):
else:
if (not clipped p__) and (not bounded p__):
addto p_ also p__ withcolor
fgalpha[(redpart p__, greenpart p__, bluepart p__),
fillcolor];
else:
begingroup save alphapict_;
picture alphapict_; alphapict_ = nullpicture;
alphafill_(p__, pathpart p__);
addto p_ also alphapict_;
endgroup;
fi
fi
fi
endfor
clip p_ to c;
addto alphapict_ also p_;
endgroup;
enddef;
mlpost-0.8.2/arrow.ml 0000664 0000000 0000000 00000023544 13060465153 0014536 0 ustar 00root root 0000000 0000000 (**************************************************************************)
(* *)
(* Copyright (C) Johannes Kanig, Stephane Lescuyer *)
(* Jean-Christophe Filliatre, Romain Bardou and Francois Bobot *)
(* *)
(* This software is free software; you can redistribute it and/or *)
(* modify it under the terms of the GNU Library General Public *)
(* License version 2.1, with the special exception on linking *)
(* described in file LICENSE. *)
(* *)
(* This software is distributed in the hope that it will be useful, *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *)
(* *)
(**************************************************************************)
open Path
(* Extended arrows. *)
let normalize = Point.normalize
let neg = Point.scale (Num.bp (-1.))
let direction_on_path f p =
Path.direction (f *. Path.length p) p
let point_on_path f p =
Path.point (f *. Path.length p) p
let subpath_01 f t p =
let l = Path.length p in
Path.subpath (f *. l) (t *. l) p
(* Atoms *)
type line = {
brush : Types.brush;
from_point: float;
to_point: float;
dist: Num.t;
}
type head_description = {
hd_command: Command.t;
hd_cut: Types.path option;
}
let make_head ?cut command = {
hd_command = command;
hd_cut = cut;
}
type head = Point.t -> Point.t -> head_description
type belt = {
clip: bool;
rev: bool;
point: float;
head: head;
}
type kind = {
lines: line list;
belts: belt list;
}
let empty = {
lines = [];
belts = [];
}
let add_line ?brush ?dashed ?color ?pen ?(from_point = 0.) ?(to_point = 1.)
?(dist = Num.bp 0.) kind =
let brush = Types.mkBrushOpt brush color pen dashed in
{ kind with lines = {
brush = brush;
from_point = from_point;
to_point = to_point;
dist = dist;
} :: kind.lines }
let head_classic_points ?(angle = 60.) ?(size = Num.bp 4.) p dir =
let dir = Point.scale size dir in
let dir_a = neg (Point.rotate (angle /. 2.) dir) in
let dir_b = neg (Point.rotate (-. angle /. 2.) dir) in
let a = Point.add p dir_a in
let b = Point.add p dir_b in
a, b
let head_classic ?color ?brush ?pen ?dashed ?angle ?size p dir =
let a, b = head_classic_points ?angle ?size p dir in
let path = Path.pathp ~style: Path.jLine [a; p; b] in
make_head ~cut: path (Command.draw ?color ?brush ?pen ?dashed path)
let head_triangle ?color ?brush ?pen ?dashed ?angle ?size p dir =
let a, b = head_classic_points ?angle ?size p dir in
let path = Path.pathp ~style: Path.jLine ~cycle: Path.jLine [a; p; b] in
let cut = Path.pathp ~style: Path.jLine [a; b] in
make_head ~cut (Command.draw ?color ?brush ?pen ?dashed path)
let head_triangle_full ?color ?angle ?size p dir =
let a, b = head_classic_points ?angle ?size p dir in
let path = Path.pathp ~style: Path.jLine ~cycle: Path.jLine [a; p; b] in
let cut = Path.pathp ~style: Path.jLine [a; b] in
make_head ~cut (Command.fill ?color path)
let add_belt ?(clip = false) ?(rev = false) ?(point = 0.5)
?(head = fun x -> head_classic x) kind =
{ kind with belts = {
clip = clip;
rev = rev;
point = point;
head = head;
} :: kind.belts }
let add_head ?head kind = add_belt ~clip: true ~point: 1. ?head kind
let add_foot ?head kind = add_belt ~clip: true ~rev: true ~point: 0. ?head kind
let parallel_path path dist =
(* TODO: true parallelism (right now its a bad approximation which only works
well for straight arrows, or slightly curved arrow with a small dist) *)
let d = direction_on_path 0.5 path in
let d = Point.rotate 90. d in
let d = normalize d in
let d = Point.mult dist d in
Path.shift d path
(* Compute the path of a line along an arrow path.
Return the line (unchanged) and the computed path. *)
let make_arrow_line path line =
let path =
if line.from_point <> 0. || line.to_point <> 1. then
subpath_01 line.from_point line.to_point path
else path
in
let path = parallel_path path line.dist in
line, path
(* Compute the command and the clipping path of a belt along an arrow path.
Return the belt (unchanged), the command and the clipping path. *)
let make_arrow_belt path belt =
let p = point_on_path belt.point path in
let d = normalize (direction_on_path belt.point path) in
let d = if belt.rev then neg d else d in
let hd = belt.head p d in
belt, hd.hd_command, hd.hd_cut
(* Clip a line with a belt clipping path if needed. *)
let clip_line_with_belt (line, line_path) (belt, _, clipping_path) =
let cut =
match belt.clip, clipping_path with
| true, Some clipping_path ->
(if belt.rev then Path.cut_before else Path.cut_after) clipping_path
| false, _ | true, None ->
fun x -> x
in
line, cut line_path
(* Compute the command to draw a line. *)
let draw_line (line, line_path) =
Command.draw ~brush:line.brush line_path
let classic = add_head (add_line empty)
let triangle = add_head ~head: head_triangle (add_line empty)
let triangle_full = add_head ~head: head_triangle_full (add_line empty)
let implies =
add_head
(add_line ~dist: (Num.cm 0.035)
(add_line ~dist: (Num.cm (-0.035))
empty))
let iff = add_foot implies
let draw ?(kind = triangle_full) ?tex ?(pos = 0.5) ?anchor path =
let lines, belts = kind.lines, kind.belts in
let lines = List.map (make_arrow_line path) lines in
let belts = List.map (make_arrow_belt path) belts in
let lines =
List.map (fun line -> List.fold_left clip_line_with_belt line belts) lines in
let lines = List.map draw_line lines in
let belts = List.map (fun (_, x, _) -> x) belts in
let labels = match tex with
| None -> []
| Some tex ->
[Command.label ?pos: anchor (Picture.tex tex) (point_on_path pos path)]
in
Command.seq (lines @ belts @ labels)
(* Instances *)
type ('a,'b) arrow_from_to =
?kind: kind -> ?tex: string -> ?pos: float ->
?anchor: Command.position ->
?style:Path.joint -> ?outd: Path.direction -> ?ind: Path.direction ->
?sep:Num.t ->
'a -> 'b -> Command.t
let point_to_point ?kind ?tex ?pos ?anchor ?style ?outd ?ind ?sep a b =
let r, l = outd, ind in
let path = (Path.pathk ?style [Path.knotp ?r a; Path.knotp ?l b]) in
let path = match sep with
| None -> path
| Some n -> Path.strip n path in
draw ?kind ?tex ?pos ?anchor path
let box_to_box ?kind ?tex ?pos ?anchor ?style ?outd ?ind ?sep a b =
draw ?kind ?tex ?pos ?anchor (Box.cpath ?style ?outd ?ind ?sep a b)
let box_to_point ?kind ?tex ?pos ?anchor ?style ?outd ?ind ?sep a b =
draw ?kind ?tex ?pos ?anchor (Box.cpath_left ?style ?outd ?ind ?sep a b)
let point_to_box ?kind ?tex ?pos ?anchor ?style ?outd ?ind ?sep a b =
draw ?kind ?tex ?pos ?anchor (Box.cpath_right ?style ?outd ?ind ?sep a b)
(*******************************************************************************)
(* To be sorted *)
(*******************************************************************************)
let simple_point_point ?style ?outd ?ind ?sep a b =
let r,l = outd, ind in
Box.strip ?sep (pathk ?style [knotp ?r a; knotp ?l b])
(*let normalize p =
Point.scale (Num.divn (Num.bp 1.) (Point.length p)) p*)
let neg = Point.scale (Num.bp (-1.))
let thick_path ?style ?outd ?ind ?(width = Num.bp 10.)
?(head_length = Num.multf 2. width)
?(head_width = head_length)
a b =
let path = simple_point_point ?style ?outd ?ind a b in
let a_dir = normalize (Path.direction 0. path) in
let a_normal = Point.rotate 90. a_dir in
let a1 = Point.add (Point.scale (Num.divf width 2.) a_normal) a in
let a2 = Point.add (Point.scale (Num.divf width (-2.)) a_normal) a in
let b_dir = normalize (Path.direction 1. path) in
let b_normal = Point.rotate 90. b_dir in
let c = Point.add (Point.scale (Num.neg head_length) b_dir) b in
let c1 = Point.add (Point.scale (Num.divf width 2.) b_normal) c in
let c2 = Point.add (Point.scale (Num.divf width (-2.)) b_normal) c in
let c1' = Point.add (Point.scale (Num.divf head_width 2.) b_normal) c in
let c2' = Point.add (Point.scale (Num.divf head_width (-2.)) b_normal) c in
(* let path_ac = simple ?style ?outd ?ind a c in
let m = Path.point 0.5 path_ac in
let m_dir = normalize (Path.direction 0.5 path_ac) in
let m_dir2 = Point.scale (Num.bp 0.) m_dir in
let m_normal = Point.rotate 90. m_dir in
let m1 = Point.add (Point.scale (Num.divf width 2.) m_normal) m in
let m2 = Point.add (Point.scale (Num.divf width (-2.)) m_normal) m in*)
let path1 =
pathk ~style:jCurve [
knotp ~r: (vec a_dir) a1;
(* knotp m1;*)
knotp ~l: (vec b_dir) c1;
]
in
let path2 =
pathk ~style:jCurve [
knotp ~r: (vec (neg b_dir)) c2;
(* knotp m2;*)
knotp ~l: (vec (neg a_dir)) a2;
]
in
let path_head =
pathk ~style:jLine [
knotp c1';
knotp b;
knotp c2';
]
in
cycle ~style:jLine
(append ~style:jLine (append ~style:jLine path1 path_head) path2)
let draw_thick ?style ?(boxed=true) ?line_color ?fill_color ?outd ?ind ?width
?head_length ?head_width a b =
let p = thick_path ?style ?outd ?ind ?width ?head_length ?head_width a b in
let draw_cmd =
if boxed then Command.draw ?color:line_color p else Command.nop
in
let fill_cmd =
match fill_color with
| None -> Command.nop
| Some c -> Command.fill ~color:c p
in
Command.append fill_cmd draw_cmd
let simple ?color ?brush ?pen ?dashed p =
let kind =
add_head
~head:(head_triangle_full ?color)
(add_line ?dashed ?color ?brush ?pen empty) in
draw ~kind p
mlpost-0.8.2/backend-test.ml 0000664 0000000 0000000 00000051404 13060465153 0015744 0 ustar 00root root 0000000 0000000 (**************************************************************************)
(* *)
(* Copyright (C) Johannes Kanig, Stephane Lescuyer *)
(* Jean-Christophe Filliatre, Romain Bardou and Francois Bobot *)
(* *)
(* This software is free software; you can redistribute it and/or *)
(* modify it under the terms of the GNU Library General Public *)
(* License version 2.1, with the special exception on linking *)
(* described in file LICENSE. *)
(* *)
(* This software is distributed in the hope that it will be useful, *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *)
(* *)
(**************************************************************************)
open Mlpost
open Num
open Command
open Format
open Helpers
open Point
open Path
module T = Transform
let (++) x y = pt (cm x, cm y)
let shift x y = transform [Transform.shifted (x ++ y)]
let () = Random.init 1234
open Tree
open Box
let tabular l =
"{\\begin{tabular}{l}" ^ String.concat " \\\\ " l ^ "\\end{tabular}}"
let box_list, box_tab =
let s a b c = shift (Point.p (a,b)) c in
let b1 = tex "1" in
let b2 = s 50. 50. (tex "2") in
let b3 = s (-50.) 50. (tex "longer") in
let b4 = s 0. 30. (tex "$\\cdot$") in
let b5 = s (-30.) 0. (tex (tabular ["hig"; "her"])) in
let b6 = empty () in
[b1; b2; b3; b4; b5;],
[ [b1; b2; b3] ; [b4; b5; b6] ]
let hannotate' text bl = hbox ~padding:(Num.bp 50.) [tex text; bl]
let hannotate text bl = hannotate' text (group bl)
let vannotate' text bl = vbox ~padding:(Num.bp 50.) [tex text; bl]
let vannotate text bl = vannotate' text (group bl)
let halign_test =
let b = box_list in
draw ~debug:true
(vbox
[ hannotate "beginning" b;
hannotate "halign" (halign ~pos:`Center zero b);
hannotate "halign-bot" (halign ~pos:`Bot zero b);
hannotate "halign-top" (halign ~pos:`Top zero b)
])
let hplace_test =
let b = box_list in
draw ~debug:true
(vbox
[ hannotate "beginning" b;
hannotate "hplace" (hplace b);
hannotate "hplace-ul-mw" (hplace ~pos:`Upleft ~min_width:(Num.bp 10.) b);
hannotate "hplace-lr-sw" (hplace ~pos:`Lowright ~same_width:true b)
])
let hbox_test =
let b = box_list in
draw ~debug:true
(vbox
[ hannotate "beginning" b;
hannotate' "hbox" (hbox b);
hannotate' "hbox-pad-ul" (hbox ~pos:`Upleft ~padding:(Num.bp 20.) b);
])
let hblock_test =
let b = box_list in
draw
(vbox
[ hannotate "beginning" b;
hannotate' "hblock" (hblock b);
hannotate' "hblock-ul-mw" (hblock ~pos:`Upleft ~min_width:(Num.bp 20.) b);
hannotate' "hblock-lr-sw" (hblock ~pos:`Lowright ~same_width:true b);
])
let valign_test =
let b = box_list in
draw ~debug:true
(hbox
[ vannotate "beginning" b;
vannotate "valign" (valign ~pos:`Center zero b);
vannotate "valign-left" (valign ~pos:`Left zero b);
vannotate "valign-right" (valign ~pos:`Right zero b)
])
let vplace_test =
let b = box_list in
draw ~debug:true
(hbox
[ vannotate "beginning" b;
vannotate "vplace" (vplace b);
vannotate "vplace-ul-mh"
(vplace ~pos:`Upleft ~min_height:(Num.bp 20.) b);
vannotate "vplace-lr-sh" (vplace ~pos:`Lowright ~same_height:true b)
])
let vbox_test =
let b = box_list in
draw ~debug:true
(hbox
[ vannotate "beginning" b;
vannotate' "vbox" (vbox b);
vannotate' "vbox-pad-ul" (vbox ~pos:`Upleft ~padding:(Num.bp 20.) b);
])
let vblock_test =
let b = box_list in
draw
(hbox
[ vannotate "beginning" b;
vannotate' "vblock" (vblock b);
vannotate' "vblock-ul-mw" (vblock ~pos:`Upleft ~min_height:(Num.bp 20.) b);
vannotate' "vblock-lr-sw" (vblock ~pos:`Lowright ~same_height:true b);
])
let tabularl_test =
draw ~debug:true
(vbox
[ hannotate' "tabularl" (tabularl box_tab);
hannotate' "tabularl-lr" (tabularl ~pos:`Lowright box_tab);
])
(* Bresenham (JCF) *)
(* the data to plot are computed here *)
let x2 = 9
let y2 = 6
let bresenham_data =
let a = Array.create (x2+1) 0 in
let y = ref 0 in
let e = ref (2 * y2 - x2) in
for x = 0 to x2 do
a.(x) <- !y;
if !e < 0 then
e := !e + 2 * y2
else begin
y := !y + 1;
e := !e + 2 * (y2 - x2)
end
done;
a
(* drawing *)
let bresenham0 =
let width = bp 6. and height = bp 6. in
let g = Box.gridi (x2+1) (y2+1)
(fun i j ->
let fill = if bresenham_data.(i) = y2-j then Some Color.red else None in
Box.empty ~width ~height ?fill ~stroke:(Some Color.black) ()) in
Box.draw g
let block1 =
let b1 = hblock ~min_width:(width (tex "c"))
[empty (); tex "A"; tex "B"; tex "c"; tex "toto"] in
let b2 = hblock ~same_width:true
[tex "A"; tex "B"; tex ~fill:Color.red "c"; tex "toto"] in
draw (vbox [b1;b2])
let block2 =
draw (hblock [tex "A"; tex "B"; tex "c"; tex "toto"])
let vblock1 =
draw (vblock [tex "A"; tex "B"; tex "c"; tex "toto"])
let hbox1 =
draw (hbox ~pos:`Top [tex "."; tex "B"; tex "c"; tex "toto"])
let hbox2 =
let s b = Box.shift (Point.p (100.,100.)) b in
let stroke = Some Color.red in
let b = vbox ~stroke ~pos:`Left [tex "A"; s (tex "Bx") ; tex "c"; tex "toto"] in
let t = hbox ~stroke [b;b;b] in
draw (vbox [t;s t;t])
let simple_box =
Box.draw (Box.rect ~stroke:(Some Color.black) (Box.empty ~width:(bp 50.) ~height:(bp 50.) ()))
let hvbox =
let row = vbox [tex "A"; tex "B"; tex "C" ] in
let col = hbox [nth 0 row ; tex "D" ; tex "E"] in
seq [ draw row; draw col ]
let d1 =
let a = circle (tex "$\\sqrt2$") in
let b =
shift (2. ++ 0.) (rect ~fill:Color.purple (tex "$\\pi$"))
in
let pen = Pen.scale (bp 3.) Pen.default in
seq [ draw a;
draw b;
Command.draw
~color:Color.red
(Path.shift (1. ++ 1.) (bpath a));
draw_label_arrow ~color:Color.orange ~pen
~pos:`Upright (Picture.tex "foo") (west a) (south_east b);
box_arrow ~color:Color.blue a b;
]
open Box
let d2 =
let tex = tex ~stroke:(Some Color.black) in
let b =
hbox ~padding:(bp 10.) ~pos:`Top ~stroke:(Some Color.red) ~dx:(bp 2.)
~dy:(bp 2.)
[vbox ~padding:(bp 4.) ~pos:`Right [tex "A"; tex "BC"; tex "D"];
vbox ~padding:(bp 4.) ~pos:`Left [tex "E"; tex "FGH"]]
in
seq [draw ~debug:false b;
box_arrow (nth 1 (nth 0 b)) (nth 0 (nth 1 b))]
let proval =
let f = 7. in
let pen = Pen.rotate 40. (Pen.yscale (bp 0.5) Pen.square) in
let check = jointpath [-1.2,1.2; 0., -2. ; 2., 2. ; 5., 5.] [jLine ; jCurve; jCurve] in
seq [ fill ~color:(Color.gray 0.2) (Path.scale (Num.bp f) fullcircle) ;
label ~pos:`Left (Picture.tex "Pr") (Point.p (f /. (-4.),0.)) ;
label ~pos:`Right (Picture.tex "al") (Point.p (f /. 4.,0.)) ;
Command.draw ~color:Color.green ~pen check;]
open Tree
let yannick style =
let tt s = Box.tex ~style ~fill:Color.orange ("\\texttt{" ^ s ^ "}") in
let node s = node ~ls:(bp 20.) ~cs:(bp 10.) ~edge_style:Square (tt s) in
let leaf s = leaf (tt s) in
let tree =
node "ComposerPage"
[ leaf "MemSet";
node "ComposerMessages"
[ node "ComposerMsg"
[ leaf "StrCpy"; leaf "DeclarerPanneRobustesse" ]
]
]
in
draw tree
let rec random_tree ?arrow_style ?edge_style ?stroke ?pen ?sep n =
let random_tree = random_tree ?arrow_style ?edge_style ?stroke ?pen ?sep in
let tex s = shadow (tex ~fill:Color.yellow ~stroke:(Some Color.black) s) in
match n with
| 1 -> leaf (tex "1")
| 2 ->
node ?arrow_style ?edge_style ?stroke ?pen ?sep
(Box.tex ~style:Box.Rect ~fill:(Color.rgb 0.5 0.3 0.2) "2")
[leaf (tex "1")]
| n ->
let k = 1 + Random.int (n - 2) in
node ?arrow_style ?edge_style ?stroke ?pen ?sep
(tex (string_of_int n))
[random_tree k; random_tree (n - 1 - k)]
let d2c, d2s, d2sq, d2hsq =
(* let ls = bp (-1.0) in *)
let stroke = Color.blue and pen = Pen.circle and arrow_style = Directed in
draw (random_tree ~edge_style:Curve ~arrow_style ~stroke ~pen ~sep:(bp 5.) 17),
draw (random_tree ~edge_style:Straight ~arrow_style ~stroke ~pen ~sep:(bp 3.) 17),
draw (random_tree ~edge_style:Square ~arrow_style ~stroke ~pen 17),
draw (random_tree ~edge_style:HalfSquare ~arrow_style ~stroke ~pen 17)
let d5 =
let rand_tree name i =
set_name name (set_stroke Color.black
(to_box (random_tree i))) in
let t1 = rand_tree "1" 5 in
let t2 = rand_tree "2" 6 in
let bl = Box.hbox ~padding:(Num.cm 2.) [ box t1; box t2] in
let b1 = nth 0 (get "1" bl) in
let b2 = nth 0 (nth 0 (nth 1 (get "2" bl))) in
seq [ Box.draw bl; box_arrow ~sep:(bp 5.) b1 b2; ]
let tree1 () = pic (draw (random_tree (1 + Random.int 5)))
let rec random_tree2 = function
| 1 -> leaf (tree1 ())
| 2 -> node ~cs:(mm 0.2) (tree1 ()) [leaf (tree1 ())]
| n ->
let k = 1 + Random.int (n - 2) in
node ~cs:(mm 0.2) (tree1 ()) [random_tree2 k; random_tree2 (n - 1 - k)]
let d6 = draw (random_tree2 10)
let cheno011 =
let p = Path.path ~cycle:jCurve [(0.,0.); (30.,40.); (40.,-20.); (10.,20.)]
in
let pen = Pen.scale (bp 1.5) Pen.circle in
seq [Command.draw p;
seq (List.map
(fun (pos, l, i) ->
Command.dotlabel ~pos (Picture.tex l) (point i p))
[`Bot, "0", 0.; `Upleft, "1", 1. ;
`Lowleft, "2", 2. ; `Top, "3", 3. ; `Left, "4", 4. ]);
Command.draw ~pen (subpath 1.3 3.2 p)]
open Dash
let d3 =
let p = pathp [cmp (0., 0.); cmp (5., 0.)] in
let pat = pattern [on (bp 6.); off (bp 12.); on (bp 6.)] in
Command.draw p ~dashed:pat
let d4 =
seq [cheno011;
iter 1 5
(fun i ->
Picture.transform [T.rotated (10. *. float i)] cheno011)
]
let d7 =
let pic =
Picture.transform [T.scaled (bp 4.)] (Picture.tex "bound this!") in
let pbox = pathp ~style:jLine ~cycle:jLine
[Picture.ulcorner pic; Picture.urcorner pic;
Picture.lrcorner pic; Picture.llcorner pic] in
seq [pic;
Command.draw (Picture.bbox pic);
Command.draw pbox;
Command.dotlabel ~pos:`Left (Picture.tex "ulcorner") (Picture.ulcorner pic);
Command.dotlabel ~pos:`Left (Picture.tex "llcorner") (Picture.llcorner pic);
Command.dotlabel ~pos:`Right (Picture.tex "urcorner") (Picture.urcorner pic);
Command.dotlabel ~pos:`Right (Picture.tex "lrcorner") (Picture.lrcorner pic);
]
let half pic = Picture.transform [Transform.scaled (bp 0.5)] pic
let rec right_split n pic =
if n <= 0 then pic
else
let smaller = right_split (n-1) (half pic) in
Picture.beside pic (Picture.below smaller smaller)
let d11 =
let p1 =
Picture.transform [Transform.rotated 90.] (Picture.tex "recursion") in
p1
(* right_split 4 p1 *)
let rec sierpinski p n =
if n = 0 then p else
let sp = sierpinski p (n-1) in
let p = half sp in
let p1 = Picture.beside p p in
Picture.below p p1
let d12 =
let p1 = Picture.tex "A" in
sierpinski p1 7
(** plots *)
open Plot
let sk = mk_skeleton 20 14 (Num.bp 20.) (Num.bp 20.)
let d13 = draw_grid sk
let squaref x = x *. x
let f2 i = sqrt (float_of_int i)
let f3 i = squaref (float_of_int i)
let d14 =
let hdash _ = Dash.scaled 0.5 Dash.withdots in
let vdash _ = Dash.scaled 2. Dash.evenly in
let hvpen i =
if i mod 5 = 0 then Pen.scale (bp 2.5) Pen.default else Pen.default in
let pen = Pen.scale (bp 4.) Pen.default in
seq [draw_grid ~hdash ~vdash ~hpen:hvpen ~vpen:hvpen sk;
draw_func ~pen f2 sk;
draw_func ~pen f3 sk
]
let f1 i =
let aux = function
| 0 -> 1
| 1 | 2 -> 2
| 3 | 4 -> 3
| 5 -> 4
| 6 | 7 -> 5
| 8 |9 -> 6
| 10 -> 7
| 11 | 12 -> 8
| 13 | 14 -> 9
| 15 -> 10
| 16 | 17 -> 11
| 18 | 19 -> 12
| 20 -> 13
| _ -> 0
in
float_of_int (aux i)
let f2 i =
let aux = function
| 0 | 1 | 2 -> 0
| 3 -> 1
| 4 -> 2
| 5 | 6 | 7 -> 3
| 8 -> 4
| 9 -> 5
| 10 | 11 | 12 -> 6
| 13 -> 7
| 14 -> 8
| 15 | 16 | 17 -> 9
| 18 -> 10
| 19 -> 11
| 20 -> 12
| _ -> 0
in
float_of_int (aux i)
let f3 i =
float_of_int ((i+3)/5)
let flab i = (Picture.transform
[Transform.scaled (bp 1.7)]
(Picture.tex (Printf.sprintf "$f_{\\omega_%d}$" i)),
`Top, 19)
let instants =
let pen = Pen.scale (bp 2.5) Pen.default in
let base =
Command.draw ~pen (Path.path ~style:jLine [(0.,-65.); (280.,-65.)]) in
let tick i =
let xi = float_of_int i *. 14. in
let yi = if f1 i = f1 (i-1) then -60. else -45. in
let p = Path.path ~style:jLine [(xi,-65.); (xi, yi)] in
Command.draw ~pen p
in
Command.seq
[base; Command.iter 0 20 tick;
Command.label (Picture.transform [Transform.scaled two]
(Picture.tex "$\\omega_1$")) (p (-20., -55.))]
let florence =
let sk = mk_skeleton 20 14 (bp 14.) (bp 20.) in
let pen = Pen.scale (bp 4.) Pen.default in
let pen2 = Pen.scale (bp 3.) Pen.default in
let dash _ = Dash.scaled 0.5 Dash.withdots in
let dash2 = Dash.scaled 0.66 Dash.withdots in
let dash3 = Dash.scaled 0.9 Dash.evenly in
let vcaption, hcaption =
let tr = [Transform.scaled (bp 1.5)] in
Picture.transform tr (Picture.tex "\\textsf{Number of ones}"),
Picture.transform tr (Picture.tex "\\textsf{Instants}") in
let plot = draw_func ~drawing:Stepwise ~style:jLine in
seq [ draw_grid ~hdash:dash ~vdash:dash ~color:(Color.gray 0.5) sk;
draw_axes ~closed:true ~hcaption ~vcaption sk;
plot ~pen ~label:(flab 1) f1 sk;
plot ~pen:pen2 ~dashed:dash2 ~label:(flab 2) f2 sk;
plot ~pen ~dashed:dash3 ~label:(flab 3) f3 sk;
instants
]
let shapes1 =
Box.vbox
[Box.path (Shapes.rectangle (bp 10.) (bp 20.));
Box.path (Shapes.rectangle (bp 35.) (bp 15.));
Box.path (Shapes.rectangle (bp 15.) (bp 35.));
Box.path (Shapes.round_rect (bp 55.) (bp 25.) (bp 10.) (bp 10.));
Box.path (Shapes.round_rect (bp 55.) (bp 25.) (bp 20.) (bp 5.));
Box.path (Shapes.round_rect (bp 70.) (bp 25.) (bp 14.) (bp 14.));
]
let shapes2 =
Box.vbox
[
(*
Shapes.arc_ellipse (f 10.) (f 10.) 0. 1.7;
Shapes.arc_ellipse ~stroke:Color.red (f 30.) (f 10.) 0. 1.7;
Shapes.arc_ellipse ~stroke:Color.red ~close:true (f 30.) (f 10.) 0. 1.7;
Shapes.arc_ellipse
~fill:Color.black ~stroke:Color.red (f 30.) (f 10.) 0. 1.7;
*)
Box.path (Shapes.ellipse (bp 10.) (bp 10.));
Box.path (Shapes.ellipse (bp 30.) (bp 10.));
Box.path (Shapes.ellipse (bp 30.) (bp 10.));
]
let farey n =
let u x = Num.bp (200.0 *. x) in
let circle x y r =
Command.fill ~color:Color.lightgray
(Path.shift (Point.pt (u y, u x))
(Path.scale (u (2.*.r)) fullcircle))
in
let quartercircle x y r theta =
Command.draw
(Path.shift (Point.pt (u y, u x))
(Path.scale (u (2.*.r)) (Path.rotate theta quartercircle)))
in
let rec aux acc p1 q1 p2 q2 =
let p = p1 + p2 in
let q = q1 + q2 in
if q>n then acc else
let fq = float q in
let fr = 0.5 /. fq /. fq in
let acc = circle (float p /. fq) fr fr :: acc in
let acc = aux acc p1 q1 p q in
aux acc p q p2 q2
in
let l =
aux [ quartercircle 0.0 0.5 0.5 90.0;
quartercircle 1.0 0.5 0.5 180.0]
0 1 1 1 in
Picture.scale (Num.bp 30.0) (Command.seq l)
let why_platform =
let tabular l =
"{\\begin{tabular}{l}" ^ String.concat " \\\\ " l ^ "\\end{tabular}}" in
let dx = bp 5. and dy = bp 5. in
let space ~name b = rect ~stroke:None ~name ~dx ~dy b in
let green s =
space ~name:s
(round_rect ~dx ~dy ~stroke:None ~fill:Color.lightgreen (tex s)) in
let pink s =
space ~name:s (shadow (rect ~dx ~dy ~fill:(Color.color "light pink")
(tex ("\\large\\sf " ^ s)))) in
let interactive = tex ~name:"interactive"
(tabular ["Interactive provers"; "(Coq, PVS,"; "Isabelle/HOL, etc.)"]) in
let automatic = tex ~name:"automatic"
(tabular ["Automatic provers";
"(Alt-Ergo, Simplify,"; "Yices, Z3, CVC3, etc.)"]) in
let b =
tabularl ~hpadding:(bp 20.) ~vpadding:(bp 30.)
[[green "Annotated C programs"; empty ();
green "JML-annotated Java programs"];
[pink "Caduceus"; green "Why program"; pink "Krakatoa";];
[empty (); pink "Why"; empty ()];
[interactive; green "verification conditions"; automatic]]
in
let arrow x y =
let p = Box.cpath (get x b) (get y b) in
Arrow.draw_thick ~line_color:Color.red ~width:(bp 4.) ~head_width:(bp 10.)
~fill_color:Color.red (Path.point 0. p) (Path.point 1. p)
in
seq [Box.draw b;
arrow "Annotated C programs" "Caduceus";
arrow "Caduceus" "Why program";
arrow "JML-annotated Java programs" "Krakatoa";
arrow "Krakatoa" "Why program";
arrow "Why program" "Why";
arrow "Why" "verification conditions";
arrow "verification conditions" "interactive";
arrow "verification conditions" "automatic";
]
(***
let alt_ergo =
let b =
tabularl ~hpadding:(bp 20.) ~vpadding:(bp 30.)
[[green "Annotated C programs"; empty ();
green "JML-annotated Java programs"];
[pink "Caduceus"; green "Why program"; pink "Krakatoa";];
[empty (); pink "Why"; empty ()];
[interactive; green "verification conditions"; automatic]]
in
[Box.draw b]
***)
let rotatedbox =
let t = tex "$A^{-1}$" in
let b1 = Box.rotate 90. t in
Box.draw (Box.hblock [b1;t])
let style = RoundRect
let stroke = Some Color.black
let pen = Pen.scale (bp 2.) Pen.circle
let dx = bp 5.
let dy = dx
let tex = Box.tex ~style ~pen ~dx ~dy
let tex' = Box.tex ~style ~pen ~dx ~dy:(bp 10.)
let assia_schema =
let tabular l =
"{\\begin{tabular}{l}" ^ String.concat " \\\\ " l ^ "\\end{tabular}}" in
let lang = tex ~stroke:(Some Color.red) "langage de developpement de preuves" in
let genie = Box.tex "Genie logiciel formel" in
let moteur =
tex' ~stroke:(Some Color.purple)
(tabular ["moteur de"; "dev de preuves"]) in
let verif =
tex' ~stroke:(Some Color.purple)
(tabular ["verificateur";" de preuves"]) in
let langf =
Box.round_rect
~stroke:(Some Color.blue) ~pen
~dx:(bp 50.) ~dy:(bp 10.) (Box.tex "langage formel") in
let h = Box.hbox ~padding:(bp 20.) [moteur;verif] in
let v =
Box.vbox
~dx ~dy:(bp 10.) ~pen
~padding:(bp 5.) ~style ~stroke:(Some Color.orange) [lang; genie]
in
Box.draw (Box.vbox ~padding:(bp (-5.)) [langf; h;v])
let grid_with_padding =
let red s = rect ~stroke:None ~fill:Color.lightred (tex s) in
let blue s = rect ~stroke:None ~fill:Color.lightblue (tex s) in
let b = gridl ~stroke:None ~hpadding:(bp 5.) ~vpadding:(bp 5.)
[[empty (); red "abc"; red "def"];
[blue "titre 1"; red ""; red ""];
[blue "titre 2"; red ""; red ""]]
in
Box.draw b
let grid_with_padding_2 =
let red s = rect ~stroke:None ~fill:Color.lightred (tex s) in
let blue s = rect ~stroke:None ~fill:Color.lightblue (tex s) in
let pen = Pen.scale (Num.pt 1.5) Pen.circle in
let b =
gridl ~stroke:(Some Color.white) ~pen ~hpadding:(bp 5.) ~vpadding:(bp 5.)
[[empty (); red "abc"; red "def"];
[blue "titre 1"; red ""; red ""];
[blue "titre 2"; red ""; red ""]]
in
seq [Box.draw b; Box.draw (shift (Point.pt (bp 5., bp 5.)) b)]
let figs = [
halign_test;
hplace_test;
hbox_test;
hblock_test;
valign_test;
vplace_test;
vbox_test;
vblock_test;
tabularl_test;
grid_with_padding;
grid_with_padding_2;
rotatedbox;
assia_schema;
hbox1;
hbox2;
bresenham0;
simple_box;
block1;
hvbox;
d2;
block2;
vblock1;
yannick Box.Rect;
yannick Box.Patatoid;d1;
d2sq; d2hsq; cheno011;
d3; d4;
d7; d11; d12 ;
(* farey 17; *)
florence; Box.draw shapes1; Box.draw shapes2;
d14; d13;
(*
why_platform; d5;
d6; proval; d2s; d2c;
*)
]
let _ =
let freshx =
let x = ref 0 in
let s = "testspdf" in
fun () -> s ^ (string_of_int (!x))
in
List.iter (fun x -> Metapost.emit (freshx ()) x) figs
(*
let figs =
let r = ref 0 in
List.map (fun f -> incr r; !r, f) figs
(* CM fonts do not scale well *)
let theprelude = "\\documentclass[a4paper]{article}
\\usepackage[T1]{fontenc}
\\usepackage{times}
"
let () =
Metapost.generate_mp ~prelude:theprelude "test/tests.mp" figs;
Misc.write_to_formatted_file "test/tests.tex"
(fun fmt ->
fprintf fmt "\\documentclass[a4paper]{article}@.";
fprintf fmt "\\usepackage[T1]{fontenc}@.";
fprintf fmt "\\usepackage{times}@.";
fprintf fmt "\\usepackage{fullpage}@.";
fprintf fmt "\\usepackage[]{graphicx}@.";
fprintf fmt "@[\\begin{document}@.";
List.iter
(fun (i,_) ->
fprintf fmt "@\n %i\\quad" i;
fprintf fmt "\\includegraphics[width=\\textwidth,height=\\textheight,keepaspectratio]{tests.%d}" i;
fprintf fmt "@\n \\vspace{3cm}@\n"
) figs;
fprintf fmt "@]@\n\\end{document}@.")
*)
mlpost-0.8.2/backend/ 0000775 0000000 0000000 00000000000 13060465153 0014431 5 ustar 00root root 0000000 0000000 mlpost-0.8.2/backend/_tags 0000664 0000000 0000000 00000000376 13060465153 0015457 0 ustar 00root root 0000000 0000000 <*dvicairo.*> or : pkg_lablgtk2, pkg_cairo.lablgtk2
<*dvicairo.*> : pkg_cairo
: pkg_cairo
: pkg_cairo
: pkg_cairo
<*.cmx> : for-pack(Mlpost)
: include_freetype
: pkg_cairo mlpost-0.8.2/backend/draw.ml 0000664 0000000 0000000 00000011643 13060465153 0015725 0 ustar 00root root 0000000 0000000 (**************************************************************************)
(* *)
(* Copyright (C) Johannes Kanig, Stephane Lescuyer *)
(* Jean-Christophe Filliatre, Romain Bardou and Francois Bobot *)
(* *)
(* This software is free software; you can redistribute it and/or *)
(* modify it under the terms of the GNU Library General Public *)
(* License version 2.1, with the special exception on linking *)
(* described in file LICENSE. *)
(* *)
(* This software is distributed in the hope that it will be useful, *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *)
(* *)
(**************************************************************************)
open Point_lib
module S = Spline_lib
let draw_tex cr tex =
Cairo.save cr;
Cairo.transform cr tex.Gentex.trans;
Dvicairo.draw
{Dvicairo.pic = cr; x_origin = 0.; y_origin = 0.} tex.Gentex.tex;
Cairo.restore cr
(*;Format.printf "Gentex : %a@." print tex*)
module MetaPath =
struct
type pen = Matrix.t
let curve_to cr s =
let _, sb, sc, sd = Spline.explode s in
Cairo.curve_to cr sb.x sb.y sc.x sc.y sd.x sd.y
let draw_path cr = function
| S.Path p ->
begin match p.S.pl with
| [] -> assert false
| (x::_) as l ->
let sa = Spline.left_point x in
Cairo.move_to cr sa.x sa.y;
List.iter (curve_to cr) l
end ;
if p.S.cycle then Cairo.close_path cr
| S.Point _ ->
failwith "Metapost fail in that case what should I do???"
let stroke cr pen = function
| S.Path _ as path ->
(*Format.printf "stroke : %a@." S.print path;*)
draw_path cr path;
Cairo.save cr;
(*Matrix.set*) Cairo.transform cr pen;
Cairo.stroke cr;
Cairo.restore cr;
| S.Point p ->
(*Format.printf "stroke : %a@." S.print path;*)
Cairo.save cr;
Cairo.transform cr (Matrix.translation p);
Cairo.transform cr pen;
draw_path cr (Metapath_lib.Approx.fullcircle 1.);
Cairo.fill cr;
Cairo.restore cr
let fill cr path = draw_path cr path; Cairo.fill cr
end
module Picture =
struct
open Concrete_types
exception Not_implemented of string
let not_implemented s = raise (Not_implemented s)
let rec color cr = function
| OPAQUE (RGB (r,g,b)) -> Cairo.set_source_rgb cr r g b
| OPAQUE (CMYK _) -> not_implemented "cmyk"
| OPAQUE (Gray g) -> color cr (OPAQUE (RGB (g,g,g)))
| TRANSPARENT (a,RGB (r,g,b)) -> Cairo.set_source_rgba cr r g b a
| TRANSPARENT (a,CMYK _) -> not_implemented "cmyk"
| TRANSPARENT (a,(Gray g)) -> color cr (TRANSPARENT (a,RGB (g,g,g)))
let color_option cr = function
| None -> ()
| Some c -> color cr c
let dash cr = function
| None | Some (_,[]) -> ();
| Some (f,l) -> Cairo.set_dash cr (Array.of_list l) f
let inversey cr height =
Cairo.translate cr ~tx:0. ~ty:height;
Cairo.scale cr ~sx:1. ~sy:(-.1.)
open Picture_lib
let rec draw_aux cr = function
| Empty -> ()
| Transform (m,t) ->
Cairo.save cr;
Cairo.transform cr m;
(*Format.printf "Transform : %a@." Matrix.print m;*)
draw_aux cr t;
Cairo.restore cr
| OnTop l -> List.iter (draw_aux cr) l
| Tex t ->
Cairo.save cr;
Cairo.scale cr ~sx:1. ~sy:(-.1.);
draw_tex cr t;
Cairo.restore cr
| Stroke_path(path,c,pen,d) ->
Cairo.save cr;
color_option cr c;
dash cr d;
MetaPath.stroke cr pen path;
Cairo.restore cr
| Fill_path (path,c)->
Cairo.save cr;
color_option cr c;
MetaPath.fill cr path;
Cairo.restore cr
| Clip (com,p) ->
Cairo.save cr;
MetaPath.draw_path cr p;
Cairo.clip cr;
draw_aux cr com;
Cairo.restore cr
| ExternalImage (filename,height,m) ->
Cairo.save cr;
Cairo.transform cr m;
inversey cr height;
let img = Cairo_png.image_surface_create_from_file filename in
Cairo.set_source_surface cr img 0. 0.;
Cairo.paint cr;
Cairo.restore cr
let draw cr width height p =
Cairo.save cr;
inversey cr height;
Cairo.set_line_width cr default_line_size;
(* Only elliptical pens use the stroke command *)
Cairo.set_line_cap cr Cairo.LINE_CAP_ROUND;
Cairo.set_line_join cr Cairo.LINE_JOIN_ROUND;
draw_aux cr (content p);
Cairo.restore cr
let where cr t (x,y) = not_implemented "where"
let move t id p = not_implemented "move"
end
mlpost-0.8.2/backend/draw.mli 0000664 0000000 0000000 00000003224 13060465153 0016072 0 ustar 00root root 0000000 0000000 (**************************************************************************)
(* *)
(* Copyright (C) Johannes Kanig, Stephane Lescuyer *)
(* Jean-Christophe Filliatre, Romain Bardou and Francois Bobot *)
(* *)
(* This software is free software; you can redistribute it and/or *)
(* modify it under the terms of the GNU Library General Public *)
(* License version 2.1, with the special exception on linking *)
(* described in file LICENSE. *)
(* *)
(* This software is distributed in the hope that it will be useful, *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *)
(* *)
(**************************************************************************)
val draw_tex : Cairo.t -> Gentex.t -> unit
module MetaPath :
sig
type pen = Matrix.t
val stroke : Cairo.t -> pen -> Spline_lib.path -> unit
val fill : Cairo.t -> Spline_lib.path -> unit
val draw_path : Cairo.t -> Spline_lib.path -> unit
end
module Picture :
sig
val draw : Cairo.t -> float -> float -> Picture_lib.t -> unit
val where : Cairo.t -> Picture_lib.t -> float * float -> Picture_lib.id list
val move :
Cairo.t -> Picture_lib.t -> Picture_lib.id -> float * float -> float * float
end
mlpost-0.8.2/backend/dvicairo.ml 0000664 0000000 0000000 00000010646 13060465153 0016572 0 ustar 00root root 0000000 0000000 (**************************************************************************)
(* *)
(* Copyright (C) Johannes Kanig, Stephane Lescuyer *)
(* Jean-Christophe Filliatre, Romain Bardou and Francois Bobot *)
(* *)
(* This software is free software; you can redistribute it and/or *)
(* modify it under the terms of the GNU Library General Public *)
(* License version 2.1, with the special exception on linking *)
(* described in file LICENSE. *)
(* *)
(* This software is distributed in the hope that it will be useful, *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *)
(* *)
(**************************************************************************)
open Format
open Dviinterp
open Mlpost_ft
type multi_page_pic = {pic :Cairo.t;
x_origin : float;
y_origin : float
}
let conversion = 0.3937 *. 72.
let point_of_cm cm = conversion *. cm
let fonts_known = Hashtbl.create 30
let find_font font =
let font_name = font.Fonts.glyphs_tag in
try Hashtbl.find fonts_known font_name
with Not_found ->
if Defaults.get_debug () then printf "Cairo : Loading font@.";
let face = font.Fonts.glyphs_ft in
let f = Cairo_ft.font_face_create_for_ft_face face 0 in
Hashtbl.add fonts_known font_name f;f
let clean_up () = ()
let set_source_color pic = function
| RGB(r,g,b) ->
if Defaults.get_debug () then
printf "Use color RGB (%f,%f,%f)@." r g b;
Cairo.set_source_rgb pic r g b
| Gray(g) ->
if Defaults.get_debug () then
printf "Use color Gray (%f)@." g;
Cairo.set_source_rgb pic g g g
| CMYK _ -> failwith "dvicairo : I don't know how to convert CMYK\
to RGB and cairo doesn't support it"
| HSB _ -> failwith "dvicairo : I'm lazy I haven't written this conversion"
(* http://en.wikipedia.org/wiki/HSL_and_HSV#Conversion_from_HSV_to_RGB
and in color.ml*)
let fill_rect s dinfo x1 y1 w h =
let x1 = point_of_cm x1 +. s.x_origin
and y1 = point_of_cm y1 +. s.y_origin
and w = point_of_cm w
and h = point_of_cm h in
if Defaults.get_debug () then
printf "Draw a rectangle in (%f,%f) with w=%f h=%f@." x1 y1 w h;
Cairo.save s.pic;
set_source_color s.pic dinfo.Dviinterp.color;
Cairo.rectangle s.pic x1 y1 w h;
Cairo.fill s.pic;
Cairo.restore s.pic
let draw_type1 s text_type1 =
let dinfo = text_type1.c_info in
let font = text_type1.c_font in
let char = text_type1.c_glyph in
let x,y = text_type1.c_pos in
let f = find_font font in
let char = font.Fonts.glyphs_enc (Int32.to_int char)
and x = point_of_cm x +. s.x_origin
and y = point_of_cm y +. s.y_origin
and ratio = point_of_cm font.Fonts.glyphs_ratio_cm in
if Defaults.get_debug () then begin
try
printf "Draw the char %i(%c) in (%f,%f) x%f@."
char (Char.chr char) x y ratio;
with _ ->
printf "Draw the char %i in (%f,%f) x%f@." char x y ratio
end;
Cairo.save s.pic;
set_source_color s.pic dinfo.Dviinterp.color;
Cairo.set_font_face s.pic f ;
Cairo.set_font_size s.pic ratio;
(* slant and extend *)
(match font.Fonts.slant with
| Some a when Defaults.get_verbosity () ->
printf "slant of %f not used@." a
| Some _ | None -> ());
(match font.Fonts.extend with
| Some a when Defaults.get_debug () ->
printf "extend of %f not used@." a
| Some _ | None -> ());
Cairo.show_glyphs s.pic
[|{Cairo.index = char;
Cairo.glyph_x = x;
Cairo.glyph_y = y}|];
Cairo.stroke s.pic;
Cairo.restore s.pic
let _specials s info xxx x y =
if Defaults.get_debug () then
printf "specials : \"%s\" at (%f,%f)@." xxx x y
let rec draw_string s text =
draw_commands s (decompose_text text)
and draw_command s = function
| Fill_rect (info, x, y, w, h) -> fill_rect s info x y w h
| Draw_text text -> draw_string s text
| Specials (info,xxx,x,y) -> _specials s info xxx x y
| Draw_text_type1 text_type1 -> draw_type1 s text_type1
and draw_commands s = List.iter (draw_command s)
let draw = draw_commands
mlpost-0.8.2/backend/dvicairo.mli 0000664 0000000 0000000 00000000313 13060465153 0016731 0 ustar 00root root 0000000 0000000 type multi_page_pic = {pic :Cairo.t;
x_origin : float;
y_origin : float
}
val draw : multi_page_pic -> Dviinterp.command list -> unit
mlpost-0.8.2/backend/icairost.ml 0000664 0000000 0000000 00000010317 13060465153 0016602 0 ustar 00root root 0000000 0000000 (**************************************************************************)
(* *)
(* Copyright (C) Johannes Kanig, Stephane Lescuyer *)
(* Jean-Christophe Filliatre, Romain Bardou and Francois Bobot *)
(* *)
(* This software is free software; you can redistribute it and/or *)
(* modify it under the terms of the GNU Library General Public *)
(* License version 2.1, with the special exception on linking *)
(* described in file LICENSE. *)
(* *)
(* This software is distributed in the hope that it will be useful, *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *)
(* *)
(**************************************************************************)
open Point_lib
open Format
let create create_surface out_file (draw:Cairo.t -> unit) height width =
if Defaults.get_debug () then printf "height = %f, width = %f@." height width;
let oc = open_out out_file in
let s = create_surface oc ~width_in_points:width ~height_in_points:height in
let cr = Cairo.create s in
draw cr;
if Defaults.get_debug () then printf "Clean up surface_finish ...@.";
Cairo.surface_finish s;
if Defaults.get_debug () then printf "Clean up close file ...@.";
close_out oc
let rec iter_after f after = function
| [] -> ()
| [a] -> f a
| a::l -> f a; after a;iter_after f after l
let error_replace_by_tex msg_error f arg =
match msg_error with
| None -> f arg
| Some w -> try f arg with exn ->
let msg = sprintf "Error : %s" (Printexc.to_string exn) in
let msg = Picture.escape_all msg in
printf "%s@." msg;
f (Types.mkPicture (Types.mkPITex (sprintf
"\\begin{minipage}{%f pt}
%s
\\end{minipage}
" w msg)))
let min_if_inf = {x= -1.;y= -1.}
let max_if_inf = {x= 1.;y= 1.}
let emit_gen ?msg_error create next_page figs =
(*Format.printf "Fig : %a@." Print.commandpic (List.hd figs);*)
let figs =
Compute.commandpicl_error (error_replace_by_tex msg_error) figs in
let (min,max) = Point_lib.list_min_max Picture_lib.bounding_box figs in
let min = norm_infinity min_if_inf min in
let max = norm_infinity max_if_inf max in
let ({x=xmin;y=ymin},{x=xmax;y=ymax}) = min,max in
(*Point_lib.sub min Compute.bbox_offset,
Point_lib.add max Compute.bbox_offset in*)
let height = ymax -. ymin in
let width = xmax -. xmin in
let not_null f = if f <= 0. then 1. else f in
let height = not_null height and width = not_null width in
let figs = List.map (fun fig -> Picture_lib.shift fig (-.xmin) (-.ymin))
figs in
(* try *)
create (fun cr ->
iter_after (Draw.Picture.draw cr width height)
(next_page cr) figs
) height width
(* with Cairo.Error e -> invalid_arg *)
(* ("Cairost generation error :" ^ (Cairo.string_of_status e)) *)
let dumb_next_page _ _ = assert false
let emit_pdf ?msg_error fname fig =
emit_gen ?msg_error
(create Cairo_pdf.surface_create_for_channel fname) dumb_next_page [fig]
let emit_ps fname fig =
emit_gen (create Cairo_ps.surface_create_for_channel fname)
dumb_next_page [fig]
let emit_svg fname fig =
emit_gen (create Cairo_svg.surface_create_for_channel fname)
dumb_next_page [fig]
let emit_png fname fig = emit_gen
(fun draw height width ->
let width = int_of_float (ceil width) in
let height = int_of_float (ceil height) in
let surf = Cairo.image_surface_create
Cairo.FORMAT_ARGB32 ~width ~height in
let cr = (Cairo.create surf) in
draw cr;
Cairo_png.surface_write_to_file surf fname) dumb_next_page [fig]
let emit_cairo cairo (width,height) fig =
(*Compute.clear (); LookForTeX.clear ();*)
let fig = Compute.commandpic fig in
Draw.Picture.draw cairo width height fig
let emit_pdfs fname figs = emit_gen
(create Cairo_pdf.surface_create_for_channel fname)
(fun cr _ -> Cairo.show_page cr) figs
mlpost-0.8.2/backend/libmlpost_ft.clib 0000664 0000000 0000000 00000000016 13060465153 0017757 0 ustar 00root root 0000000 0000000 ml_mlpost_ft.o mlpost-0.8.2/backend/ml_mlpost_ft.c 0000664 0000000 0000000 00000001700 13060465153 0017272 0 ustar 00root root 0000000 0000000
#include
#include
#define CAML_NAME_SPACE
#include
#include
#include FT_FREETYPE_H
#define FT_Face_val(v) (FT_Face)(Field(v, 0))
CAMLprim value
ml_FT_Get_Name_Index(value font, value char_name)
{
int index = FT_Get_Name_Index (FT_Face_val (font),
String_val (char_name));
return Val_int (index);
}
CAMLprim value
ml_FT_Get_Char_Index(value font, value charcode)
{
int index = FT_Get_Char_Index (FT_Face_val (font),
Long_val (charcode));
return Val_int (index);
}
CAMLprim value
ml_FT_num_charmaps(value font)
{
FT_Face face = FT_Face_val (font);
return Val_int (face->num_charmaps);
}
CAMLprim value
ml_FT_set_charmap(value font, value charmap_index)
{
FT_Face face = FT_Face_val (font);
FT_CharMap charmap = (face->charmaps)[Int_val(charmap_index)];
return Val_int (FT_Set_Charmap(face,charmap));
}
mlpost-0.8.2/backend/mlpost_ft.ml 0000664 0000000 0000000 00000001052 13060465153 0016770 0 ustar 00root root 0000000 0000000
open Cairo_ft
external ft_get_name_index : ft_face -> string -> int = "ml_FT_Get_Name_Index"
external ft_get_char_index : ft_face -> int -> int = "ml_FT_Get_Char_Index"
external ft_num_charmaps : ft_face -> int = "ml_FT_num_charmaps"
external ft_set_charmap : ft_face -> int -> int = "ml_FT_set_charmap"
let ft_set_charmap face index =
if index < 0 || ft_num_charmaps face <= index then
invalid_arg "ft_set_charmap : invalid charmap index";
let r = ft_set_charmap face index in
if r <> 0 then invalid_arg "ft_set_charmap : unsuccesful"
mlpost-0.8.2/backend/myocamlbuild.ml 0000664 0000000 0000000 00000010367 13060465153 0017453 0 ustar 00root root 0000000 0000000 (**************************************************************************)
(* *)
(* Copyright (C) Johannes Kanig, Stephane Lescuyer *)
(* Jean-Christophe Filliatre, Romain Bardou and Francois Bobot *)
(* *)
(* This software is free software; you can redistribute it and/or *)
(* modify it under the terms of the GNU Library General Public *)
(* License version 2.1, with the special exception on linking *)
(* described in file LICENSE. *)
(* *)
(* This software is distributed in the hope that it will be useful, *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *)
(* *)
(**************************************************************************)
open Ocamlbuild_plugin
(* open Command -- no longer needed for OCaml >= 3.10.2 *)
(* these functions are not really officially exported *)
let run_and_read = Ocamlbuild_pack.My_unix.run_and_read
let blank_sep_strings = Ocamlbuild_pack.Lexers.blank_sep_strings
let split s ch =
let x = ref [] in
let rec go s =
let pos = String.index s ch in
x := (String.before s pos)::!x;
go (String.after s (pos + 1))
in
try
go s
with Not_found -> !x
let split_nl s = split s '\n'
let before_space s =
try
String.before s (String.index s ' ')
with Not_found -> s
(* this lists all supported packages *)
let find_packages () =
List.map before_space (split_nl & run_and_read "ocamlfind list")
(* this is supposed to list available syntaxes, but I don't know how to do it. *)
let find_syntaxes () = ["camlp4o"; "camlp4r"; "bitstring.syntax"]
(* ocamlfind command *)
let ocamlfind x = S[A"ocamlfind"; x]
let _ = dispatch begin function
| Before_options ->
(* by using Before_options one let command line options have an higher priority *)
(* on the contrary using After_options will guarantee to have the higher priority *)
(* override default commands by ocamlfind ones *)
Options.ocamlc := ocamlfind & A"ocamlc";
Options.ocamlopt := ocamlfind & A"ocamlopt";
Options.ocamldep := ocamlfind & A"ocamldep";
Options.ocamldoc := ocamlfind & A"ocamldoc";
Options.ocamlmktop := ocamlfind & A"ocamlmktop"
| After_rules ->
(* When one link an OCaml library/binary/package, one should use -linkpkg *)
flag ["ocaml"; "link"] & A"-linkpkg";
(* For each ocamlfind package one inject the -package option when
* compiling, computing dependencies, generating documentation and
* linking. *)
List.iter begin fun pkg ->
flag ["ocaml"; "compile"; "pkg_"^pkg] & S[A"-package"; A pkg];
flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S[A"-package"; A pkg];
flag ["ocaml"; "doc"; "pkg_"^pkg] & S[A"-package"; A pkg];
flag ["ocaml"; "link"; "pkg_"^pkg] & S[A"-package"; A pkg];
end (find_packages ());
(* Like -package but for extensions syntax. Morover -syntax is useless
* when linking. *)
List.iter begin fun syntax ->
flag ["ocaml"; "compile"; "syntax_"^syntax] & S[A"-syntax"; A syntax];
flag ["ocaml"; "ocamldep"; "syntax_"^syntax] & S[A"-syntax"; A syntax];
flag ["ocaml"; "doc"; "syntax_"^syntax] & S[A"-syntax"; A syntax];
end (find_syntaxes ());
(* The default "thread" tag is not compatible with ocamlfind.
Indeed, the default rules add the "threads.cma" or "threads.cmxa"
options when using this tag. When using the "-linkpkg" option with
ocamlfind, this module will then be added twice on the command line.
To solve this, one approach is to add the "-thread" option when using
the "threads" package using the previous plugin.
*)
flag ["ocaml"; "pkg_threads"; "compile"] (S[A "-thread"]);
flag ["ocaml"; "pkg_threads"; "link"] (S[A "-thread"])
| _ -> ()
end
mlpost-0.8.2/box.ml 0000664 0000000 0000000 00000061120 13060465153 0014164 0 ustar 00root root 0000000 0000000 (**************************************************************************)
(* *)
(* Copyright (C) Johannes Kanig, Stephane Lescuyer *)
(* Jean-Christophe Filliatre, Romain Bardou and Francois Bobot *)
(* *)
(* This software is free software; you can redistribute it and/or *)
(* modify it under the terms of the GNU Library General Public *)
(* License version 2.1, with the special exception on linking *)
(* described in file LICENSE. *)
(* *)
(* This software is distributed in the hope that it will be useful, *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *)
(* *)
(**************************************************************************)
open Types
open Num
open Point
open Num.Infix
type style =
| Rect
| Circle
| RoundRect
| Patatoid
| Patatoid2
| Ellipse
| RoundBox
| Custom of (Num.t -> Num.t -> Num.t * Num.t * Path.t)
let margin = Num.bp 2.
module Name =
struct
type t =
| Internal of int
| Userdef of string
let compare = Pervasives.compare
let print fmt = function
| Internal i -> Format.pp_print_int fmt i
| Userdef s -> Format.pp_print_string fmt s
end
module NMap = Map.Make(Name)
let print_dom fmt m =
Format.fprintf fmt "@[{";
NMap.iter (fun k _ -> Format.fprintf fmt "%a;@ " Name.print k) m;
Format.fprintf fmt "}@]"
type t = {
name : Name.t;
width : Num.t;
height : Num.t;
ctr : Point.t;
stroke : Color.t option;
pen : Pen.t option;
fill : Color.t option;
contour : Path.t;
desc : desc;
dash : Dash.t option;
post_draw : t -> Command.t ;
pre_draw : t -> Command.t
}
and desc =
| Emp
| Pic of Picture.t
| Grp of t array * t NMap.t
let width b = b.width
let height b = b.height
let ctr b = b.ctr
let bpath b = b.contour
let set_bpath p b = {b with contour = p}
let halfheight b = Point.pt (zero, b.height /./ 2.)
let halfwidth b = Point.pt (b.width /./ 2., zero)
let north b = Point.add b.ctr (halfheight b)
let south b = Point.sub b.ctr (halfheight b)
let east b = Point.add b.ctr (halfwidth b)
let west b = Point.sub b.ctr (halfwidth b)
let build_point a b = Point.pt (xpart a, ypart b)
let north_west x = build_point (west x) (north x)
let north_east x = build_point (east x) (north x)
let south_west x = build_point (west x) (south x)
let south_east x = build_point (east x) (south x)
type vposition = [ |Command.vposition | `Custom of t -> Num.t]
type hposition = [ |Command.hposition | `Custom of t -> Num.t]
type vposition_red = [ |Types.vposition_red | `Custom of t -> Num.t]
type hposition_red = [ |Types.hposition_red | `Custom of t -> Num.t]
type position = [ |Command.position | `Custom of t -> Point.t]
type position_red = [ |Types.position_red | `Custom of t -> Point.t]
let hreduce = function
| `Custom c -> `Custom c
| #Command.hposition as p -> (hreduce p:> hposition_red)
let vreduce = function
| `Custom c -> `Custom c
| #Command.vposition as p -> (vreduce p:> vposition_red)
let pos_reduce = function
| `Custom c -> `Custom c
| #Command.position as p -> (pos_reduce p:> position_red)
let corner pos x =
match pos with
| `Custom c -> c x
| #Types.position as other ->
match Types.pos_reduce other with
| `Northwest -> north_west x
| `Northeast -> north_east x
| `Southwest -> south_west x
| `Southeast -> south_east x
| `West -> west x
| `East -> east x
| `Center -> ctr x
| `North -> north x
| `South -> south x
let cornerh pos x =
match pos with
| `Custom c -> c x
| #Command.position as pos -> xpart (corner pos x)
let cornerv pos x =
match pos with
| `Custom c -> c x
| #Command.position as pos -> ypart (corner pos x)
let rec transform t b =
let tr = Point.transform t in
let nw = tr (north_west b) and sw = tr (south_west b)
and se = tr (south_east b) in
let hvec = Point.sub nw sw and wvec = Point.sub se sw in
{ b with
ctr = Point.transform t b.ctr;
height = Num.abs (ypart hvec) +/ Num.abs (ypart wvec);
width = Num.abs (xpart hvec) +/ Num.abs (xpart wvec);
contour = Path.transform t b.contour;
desc = transform_desc t b.desc;
}
and transform_desc t = function
| Emp -> Emp
| Pic p -> Pic (Picture.transform t p)
| Grp (a , m ) ->
Grp (Array.map (transform t) a, NMap.map (transform t) m)
let rec shift pt b =
{ b with ctr = Point.shift pt b.ctr;
contour = Path.shift pt b.contour;
desc = shift_desc pt b.desc;
}
and shift_desc pt = function
| Emp -> Emp
| Pic p -> Pic (Picture.shift pt p)
| Grp (a,m) ->
let s = shift pt in
Grp (Array.map s a, NMap.map s m)
let scale f p = transform [Transform.scaled f] p
let rotate f p = transform [Transform.rotated f] p
let yscale n p = transform [Transform.yscaled n] p
let xscale n p = transform [Transform.xscaled n] p
let center pt x = shift (Point.sub pt x.ctr) x
let border pos b =
match pos with
| `North -> ypart (ctr b) +/ height b /./ 2.
| `South -> ypart (ctr b) -/ height b /./ 2.
| `West -> xpart (ctr b) -/ width b /./ 2.
| `East -> xpart (ctr b) +/ width b /./ 2.
let rec draw ?(debug=false) b =
let path_cmd = match b.stroke, b.pen with
| None, _ -> Command.nop
| Some color, None -> Command.draw ~color ?dashed:b.dash b.contour
| Some color, Some pen ->
Command.draw ~pen ~color ?dashed:b.dash b.contour
in
let fill_cmd = match b.fill with
| None -> Command.nop
| Some color -> Command.fill ~color b.contour
in
let contents_cmd = match b.desc with
| Emp ->
Command.nop
| Pic pic -> pic
| Grp (a, _) ->
Command.iter 0 (Array.length a - 1) (fun i -> draw ~debug a.(i))
in
let debug_cmd =
if debug then
(* TODO maybe we should better draw the rectangle [w,h]
instead of the contour *)
let rect = Path.shift b.ctr (Shapes.rectangle b.width b.height) in
Command.seq
[Command.draw ~color:Color.red ~dashed:Dash.evenly rect;
match b.name with
| Name.Internal _ -> Command.nop
| Name.Userdef s ->
Command.label ~pos:`Center
(Picture.tex ("\\tiny " ^ (Picture.escape_all s)))
(north_west b)]
else
Command.nop
in
Command.seq [b.pre_draw b; fill_cmd; contents_cmd; path_cmd; debug_cmd;
b.post_draw b]
let rect_ w h = w, h, Shapes.rectangle w h
let circ_ w h =
let m = maxn w h in
m, m, Shapes.circle m
let ellipse_ w h =
let p = Shapes.ellipse w h in
let pic = Command.draw p in
Picture.width pic, Picture.height pic, p
let round_rect_ w h =
let rx = (minn w h) /./ 10. in
w, h, Shapes.round_rect w h rx rx
let round_box_ w h =
w, h, Shapes.round_box w h
let patatoid_ w h =
let p = Shapes.patatoid w h in
let pic = Command.draw p in
Picture.width pic, Picture.height pic, p
let patatoid2_ w h =
let p = Shapes.patatoid2 w h in
let pic = Command.draw p in
Picture.width pic, Picture.height pic, p
let from_style = function
| Rect -> rect_
| Circle -> circ_
| RoundRect -> round_rect_
| Patatoid -> patatoid_
| Patatoid2 -> patatoid2_
| Ellipse -> ellipse_
| RoundBox -> round_box_
| Custom f -> f
let make_contour s ?(dx=margin) ?(dy=margin) w h c =
let w = w +/ 2. *./ dx and h = h +/ 2. *./ dy in
let w,h, p = (from_style s) w h in
w, h, Path.shift c p
let no_drawing _ = Command.nop
let fresh_name =
let x = ref 1 in
(fun () -> incr x; Name.Internal (!x) )
let mkbox ?(style=Rect) ?dx ?dy ?name ?brush ?(stroke=Some Color.black)
?pen ?dash ?fill ?(pre_draw=no_drawing) ?(post_draw=no_drawing)
w h c desc =
let w,h,s = make_contour style ?dx ?dy w h c in
let b = Brush.t ?pen ?dash ?color:stroke ?brush () in
let name =
match name with
| None -> fresh_name ()
| Some s -> Name.Userdef s in
{ desc = desc; name = name; stroke = Brush.color b; pen = Brush.pen b;
fill = fill; dash = Brush.dash b; width = w; height = h;
ctr = c; contour = s; post_draw = post_draw;
pre_draw = pre_draw }
let pic ?style ?dx ?dy ?name ?brush ?(stroke=None) ?pen ?dash ?fill pic =
let c = Picture.ctr pic in
mkbox ?style ?dx ?dy ?name ?brush ~stroke ?pen ?dash ?fill
(Picture.width pic) (Picture.height pic) c (Pic pic)
let merge_maps =
let add_one m b =
let m = match b.desc with
| Emp | Pic _ -> m
| Grp (_, m') -> NMap.fold NMap.add m' m in
NMap.add b.name b m in
List.fold_left add_one NMap.empty
let box ?style ?dx ?dy ?name ?brush ?stroke ?pen ?dash ?fill b =
mkbox ?style ?dx ?dy ?name ?brush ?stroke ?pen ?dash ?fill
(width b) (height b) (ctr b) (Grp ([|b|], merge_maps [b] ))
let path ?style ?dx ?dy ?name ?brush ?(stroke=None) ?pen ?dash ?fill p =
pic ?style ?dx ?dy ?name ?brush ~stroke ?pen ?dash ?fill
(Picture.make (Command.draw p))
let empty ?(width=Num.zero) ?(height=Num.zero) ?style ?name ?brush
?(stroke=None) ?pen ?dash ?fill () =
mkbox ?style ?name ~dx:zero ~dy:zero ?brush ~stroke ?pen ?dash ?fill
width height Point.origin Emp
let empty_from_box ?style ?name ?brush ?(stroke=None) ?pen ?dash ?fill box =
mkbox ?style ?name ?brush ~stroke ?pen ?dash ?fill
(width box) (height box) (ctr box) Emp
(* groups the given boxes in a new box *)
let group ?style ?(dx=Num.zero) ?(dy=Num.zero)
?name ?brush ?(stroke=None) ?pen ?dash ?fill bl =
let xmin b = xpart (south_west b) in
let xmax b = xpart (north_east b) in
let ymin b = ypart (south_west b) in
let ymax b = ypart (north_east b) in
match bl with
| [] -> empty ~width:dx ~height:dy ?style
?name ?brush ~stroke ?pen ?dash ?fill ()
| [b] -> box ?style ~dx ~dy ?name ?brush ~stroke ?pen ?dash ?fill b
| b::r ->
let xmin,xmax,ymin,ymax =
List.fold_left
(fun (xmin',xmax',ymin',ymax') b ->
(Num.minn xmin' (xmin b),
Num.maxn xmax' (xmax b),
Num.minn ymin' (ymin b),
Num.maxn ymax' (ymax b)))
(xmin b, xmax b, ymin b, ymax b) r
in
let w = xmax -/ xmin in
let h = ymax -/ ymin in
let c = Point.pt (xmin +/ w /./ 2., ymin +/ h /./ 2.) in
mkbox ?style ~dx ~dy ?name ?brush ~stroke ?pen ?dash ?fill w h c
(Grp (Array.of_list bl, merge_maps bl))
let group_array ?name ?brush ?stroke ?fill ?dx ?dy ba =
group ?name ?brush ?stroke ?fill ?dx ?dy (Array.to_list ba)
(* groups the given boxes in a rectangular shape of size [w,h]
and center [c] *)
let group_rect ?name ?(stroke=None) w h c bl =
mkbox ~dx:zero ~dy:zero
?name ~stroke w h c (Grp (Array.of_list bl, merge_maps bl))
type 'a box_creator =
?dx:Num.t -> ?dy:Num.t -> ?name:string ->
?brush:Brush.t -> ?stroke:Color.t option -> ?pen:Pen.t -> ?dash:Dash.t ->
?fill:Color.t -> 'a -> t
let rect = box ~style:Rect
let circle = box ~style:Circle
let ellipse = box ~style:Ellipse
let round_rect = box ~style:RoundRect
let patatoid = box ~style:Patatoid
let patatoid2 = box ~style:Patatoid2
let round_box = box ~style:RoundBox
let tex ?style ?dx ?dy ?name ?brush ?(stroke=None) ?pen ?dash ?fill s =
pic ?style ?dx ?dy ?name ?brush ~stroke ?pen ?dash ?fill (Picture.tex s)
let nth i b = match b.desc with
| Grp (a, _ ) ->
let n = Array.length a - 1 in
if i < 0 || i > n then
invalid_arg (Format.sprintf "Box.nth: index %d out of 0..%d" i n);
a.(i)
| Emp -> invalid_arg "Box.nth: empty box"
| Pic _ -> invalid_arg "Box.nth: picture box"
let elts b = match b.desc with
| Emp | Pic _ -> [||]
| Grp (a, _) -> a
let elts_list b = Array.to_list (elts b)
let get' n b =
if b.name = n then b else match b.desc with
| Emp -> invalid_arg "Box.get: empty box"
| Pic _ -> invalid_arg "Box.get: picture box"
| Grp (_, m) ->
try
NMap.find n m
with Not_found ->
invalid_arg
(Misc.sprintf "Box.get: no sub-box %a out of %a"
Name.print n print_dom m)
let get n b = get' (Name.Userdef n) b
let sub b1 b2 = get' b1.name b2
let relative b g =
let b' = sub b g in
let v = Point.sub (ctr b) (ctr b') in
shift v g
let get_fill b = b.fill
let set_fill c b = { b with fill = Some c }
let get_stroke b = b.stroke
let set_stroke s b = {b with stroke = Some s }
let clear_stroke b = { b with stroke = None }
let get_name b =
match b.name with
| Name.Internal _ -> None
| Name.Userdef s -> Some s
let get_dash b = b.dash
let set_dash d b = {b with dash = Some d }
let clear_dash b = {b with dash = None }
let set_name name b = {b with name = Name.Userdef name}
let set_post_draw f b = {b with post_draw = f}
let set_pre_draw f b = {b with pre_draw = f}
let add_post_draw f b =
let d = b.post_draw in
{ b with post_draw = (fun t -> Command.append (d t) (f t)) }
let clear_post_draw b = {b with post_draw = no_drawing }
let clear_pre_draw b = {b with pre_draw = no_drawing }
let shadow b =
let shadow b =
let shad i =
let d = bp (i /. 2.) in
Command.fill ~color:(Color.gray (0.2 +. i *. 0.2))
(Path.shift (Point.pt (d, d)) (bpath b)) in
Command.seq (List.rev_map shad [1. ; 2. ; 3.])
in
{ b with pre_draw = shadow }
let get_pen b = b.pen
let set_pen p b = { b with pen = Some p }
let set_contour c b = { b with contour = c }
(* new box primitives *)
let ycoord pos a =
(* get the vertical position of a box, using a either Top, Bot or the
center as reference *)
match vreduce pos with
| `Custom c -> c a
| #Types.vposition_red as p ->
match p with
| `Center -> ypart (ctr a)
| (`North | `South) as x -> border x a
let xcoord pos a =
(* get the horizontal position of a box, using a either Left, Right or the
center as reference *)
match hreduce pos with
| `Custom c -> c a
| #Types.hposition_red as p ->
match p with
| `Center -> xpart (ctr a)
| (`West | `East) as x -> border x a
let box_fold f acc l =
let _, l =
List.fold_left
(fun (acc,l) b -> let acc, b = f acc b in acc, b::l) (acc,[]) l in
List.rev l
let halign ?(pos : vposition =`Center) y l =
List.map (fun b -> shift (Point.pt (zero, y -/ ycoord pos b)) b) l
let set_height pos h b =
let nc =
match vreduce pos with
| `Center -> ypart b.ctr
| `North -> ypart b.ctr +/ (b.height -/ h) /./ 2.
| `South -> ypart b.ctr -/ (b.height -/ h) /./ 2.
| `Custom c -> let n = c b in
n +/ ((ypart b.ctr -/ n) */ (h // b.height))
in
{ b with height = h; ctr = Point.pt (xpart b.ctr, nc) }
let set_width pos w b =
let nc =
match hreduce pos with
| `Center -> xpart b.ctr
| `West -> xpart b.ctr -/ (b.width -/ w) /./ 2.
| `East -> xpart b.ctr +/ (b.width -/ w) /./ 2.
| `Custom c -> let n = c b in
n +/ ((xpart b.ctr -/ n) */ (w // b.width)) in
{ b with width = w; ctr = Point.pt (nc, ypart b.ctr) }
let set_gen2 mycorner chdim pos1 y1 pos2 y2 box =
let pos1 = mycorner pos1 box in
let pos2 = mycorner pos2 box in
let a = (y1 -/ y2) // (pos1 -/ pos2) in
let b = ((y2 */ pos1) -/ (y1 */ pos2)) // (pos1 -/ pos2) in
let w,h = chdim (fun x -> a */ x) (box.width,box.height) in
let ctr = chdim (fun x -> a */ x +/ b) (xpart box.ctr,ypart box.ctr) in
{ box with width = w; height = h; ctr = Point.pt ctr }
let set_height2 pos1 y1 pos2 y2 b = set_gen2 cornerv
(fun conv (x,y) -> (x, conv y)) pos1 y1 pos2 y2 b
let set_width2 pos1 y1 pos2 y2 b = set_gen2 cornerh
(fun conv (x,y) -> (conv x,y)) pos1 y1 pos2 y2 b
let valign ?(pos=`Center) x l =
List.map (fun b -> shift (Point.pt (x -/ xcoord pos b, zero)) b) l
let extractv pos =
match pos_reduce pos with
| `Northwest | `North | `Northeast -> `North
| `West | `Center | `East -> `Center
| `Southwest | `South | `Southeast -> `South
| `Custom c -> `Custom (fun t -> ypart (c t))
let extracth pos =
match pos_reduce pos with
| `Northwest | `West | `Southwest -> `West
| `North | `Center | `South -> `Center
| `Northeast | `East | `Southeast -> `East
| `Custom c -> `Custom (fun t -> xpart (c t))
let set_size pos ~width ~height b =
set_height (extractv pos) height (set_width (extracth pos) width b)
let max_height l = Num.fold_max height Num.zero l
let max_width l = Num.fold_max width Num.zero l
let same_size ?(pos=`Center) bl =
List.map (set_size pos ~width:(max_width bl) ~height:(max_height bl)) bl
let same_height ?(pos=`Center) bl =
List.map (set_height pos (max_height bl)) bl
let same_width ?(pos=`Center) bl = List.map (set_width pos (max_width bl)) bl
let hplace ?(padding=zero) ?(pos=`Center)
?(min_width=zero) ?(same_width=false) l =
if l = [] then [] else
let min_width =
if same_width then Num.maxn (max_width l) min_width else min_width in
let l =
List.map
(fun b -> set_width (extracth pos) (Num.maxn min_width b.width) b) l in
let refb = List.hd l in
let refc = ctr refb and refw = width refb in
box_fold
(fun x p ->
x+/ p.width +/ padding,
center (Point.pt (x +/ p.width /./ 2., ypart p.ctr)) p)
(xpart refc -/ refw /./ 2.) l
let vplace ?(padding=zero) ?(pos=`Center)
?(min_height=zero) ?(same_height=false) l =
if l = [] then [] else
let min_height =
if same_height then Num.maxn (max_height l) min_height else min_height in
let l =
List.map (fun b ->
set_height (extractv pos) (Num.maxn min_height b.height) b) l in
let refb = List.hd l in
let refc = ctr refb and refh = height refb in
box_fold
(fun y p ->
y -/ p.height -/ padding,
center (Point.pt (xpart p.ctr, y -/ p.height /./ 2.)) p)
(ypart refc +/ refh /./ 2.) l
let hbox_list ?padding ?(pos=`Center) ?min_width ?same_width l =
match l with
| [] -> []
| hd::_ ->
let y = ypart (corner pos hd) in
halign ~pos:(extractv pos) y
(hplace ?padding ~pos:pos ?min_width ?same_width l)
let vbox_list ?padding ?(pos=`Center) ?min_height ?same_height l =
match l with
| [] -> []
| hd::_ ->
let x = xpart (corner pos hd) in
let l = vplace ?padding ~pos ?min_height ?same_height l in
valign ~pos:(extracth pos) x l
let hequalize h l = List.map (set_height h) l
let wequalize w l = List.map (set_width w) l
let hbox ?padding ?pos ?style ?min_width ?same_width ?dx ?dy
?name ?brush ?stroke ?pen ?dash ?fill l =
group ?style ?dx ?dy ?name ?brush ?stroke ?pen ?dash ?fill
(hbox_list ?padding ?pos ?min_width ?same_width l)
let vbox ?padding ?pos ?style ?min_height ?same_height ?dx ?dy
?name ?brush ?stroke ?pen ?dash ?fill l =
group ?style ?dx ?dy ?name ?stroke ?pen ?dash ?fill
(vbox_list ?padding ?pos ?min_height ?same_height l)
let modify_box ?stroke ?pen ?dash b =
let s = match stroke with | None -> Some Color.black | Some x -> x in
{ b with stroke = s;
pen = pen;
dash = dash;
contour = Path.shift b.ctr (Shapes.rectangle b.width b.height) }
let hblock ?padding ?(pos=`Center) ?name ?stroke ?pen ?dash
?min_width ?same_width pl =
group ?name
(List.map (modify_box ?stroke ?pen ?dash)
(hbox_list ?padding ~pos ?min_width ?same_width
(List.map (set_height (extractv pos) (max_height pl)) pl)))
let vblock ?padding ?(pos=`Center) ?name ?stroke ?pen ?dash
?min_height ?same_height pl =
group ?name
(List.map (modify_box ?stroke ?pen ?dash)
(vbox_list ?padding ~pos ?min_height ?same_height
(List.map (set_width (extracth pos) (max_width pl)) pl)))
let tabularl ?hpadding ?vpadding ?(pos=`Center) ?style ?name
?stroke ?pen ?dash ?fill pll =
(* we first compute the widths of columns and heights of rows *)
let hmaxl = List.map (Num.fold_max height Num.zero) pll in
let rec calc_wmax pll = match pll with
| [] :: _ ->
[]
| _ ->
let cols, qll =
List.fold_left
(fun (col,rem) pl -> (List.hd pl :: col, List.tl pl :: rem))
([],[]) pll
in
(Num.fold_max width Num.zero cols) :: (calc_wmax qll)
in
let wmaxl = calc_wmax pll in
let pll =
List.map2 (fun row height ->
List.map2 (fun cell width ->
set_size pos ~height ~width (group [cell])) row wmaxl
) pll hmaxl in
vbox ?padding:vpadding ~pos ?style ?name ?stroke ?pen ?dash ?fill
(List.map (fun r -> hbox ?padding:hpadding ~pos r) pll)
let tabular ?(hpadding=Num.zero) ?(vpadding=Num.zero) ?pos ?style
?name ?stroke ?pen ?dash ?fill m =
let pll = Array.to_list (Array.map Array.to_list m) in
tabularl ~hpadding ~vpadding ?pos ?style ?name ?stroke ?pen ?dash ?fill pll
let tabulari ?(hpadding=Num.zero) ?(vpadding=Num.zero) ?pos ?style
?name ?stroke ?pen ?dash ?fill w h f =
let m = Array.init h (fun j -> Array.init w (fun i -> f i j)) in
tabular ~hpadding ~vpadding ?pos ?style ?name ?stroke ?pen ?dash ?fill m
let gridl ?hpadding ?vpadding ?(pos=`Center) ?stroke ?pen ?dash pll =
let hmax = Num.fold_max (Num.fold_max height Num.zero) Num.zero pll in
let wmax = Num.fold_max (Num.fold_max width Num.zero) Num.zero pll in
let pll =
List.map (fun l ->
List.map (fun c ->
set_height (extractv pos) hmax
(set_width (extracth pos) wmax c)) l) pll in
let pll =
vbox_list ~pos ?padding:vpadding
(List.map
(fun r ->
group (List.map (modify_box ?stroke ?pen ?dash)
(hbox_list ?padding:hpadding ~pos r)))
pll) in
group pll
let grid ?hpadding ?vpadding ?pos ?stroke ?pen ?dash m =
let pll = Array.to_list (Array.map Array.to_list m) in
gridl ?hpadding ?vpadding ?pos ?stroke ?pen ?dash pll
let gridi ?hpadding ?vpadding ?pos ?stroke ?pen ?dash w h f =
let m = Array.init h (fun j -> Array.init w (fun i -> f i j)) in
grid ?hpadding ?vpadding ?pos ?stroke ?pen ?dash m
let henlarge l =
let toh f x = xpart (f x) in
let min = Num.fold_min (toh west) (bp infinity) l in
let max = Num.fold_max (toh east) (bp neg_infinity) l in
List.map (set_width2 `West min `East max) l
let venlarge l =
let tow f x = ypart (f x) in
let min = Num.fold_min (tow south) (bp infinity) l in
let max = Num.fold_max (tow north) (bp neg_infinity) l in
List.map (set_height2 `North max `South min) l
module P = Path
let strip ?sep p = match sep with
| None -> p
| Some n -> Path.strip n p
let cpath ?style ?outd ?ind ?sep a b =
let r,l = outd, ind in
let p = P.pathk ?style [P.knotp ?r (ctr a); P.knotp ?l (ctr b)] in
strip ?sep (P.cut_after (bpath b) (P.cut_before (bpath a) p))
let cpath_left ?style ?outd ?ind ?sep a b =
let r,l = outd, ind in
let p = P.pathk ?style [P.knotp ?r (ctr a); P.knotp ?l b] in
strip ?sep (P.cut_before (bpath a) p)
let cpath_right ?style ?outd ?ind ?sep a b =
let r,l = outd, ind in
let p = P.pathk ?style [P.knotp ?r a; P.knotp ?l (ctr b)] in
strip ?sep (P.cut_after (bpath b) p)
(* (* Deleted because of circular dependency with the Arrow module.
It did not seem to be used anyway. *)
let thick_arrow ?style ?(boxed=true) ?line_color ?fill_color ?outd ?ind ?width
?head_length ?head_width a b =
let p = cpath a b in
let pa = Path.point 0. p in
let pb = Path.point 1. p in
Arrow.draw_thick ?style ~boxed ?line_color ?fill_color ?outd ?ind ?width
?head_length ?head_width pa pb
*)
(* Specials Points *)
let setp name pt box =
let add_smap m =
NMap.add (Name.Userdef name) (shift pt (empty ~name ())) m in
{ box with
desc =
match box.desc with
| Emp -> Grp ([|box|], add_smap NMap.empty)
| Pic _ -> Grp ([|box|], add_smap NMap.empty)
| Grp (l,m) -> Grp (l, add_smap m)}
let getp name box = ctr (get name box)
let getpx name box = xpart (getp name box)
let getpy name box = ypart (getp name box)
(*let place_relative_to
?(same_height=false)
?(pos=`Center)
?pos2
?(offset=Num.zero)
?(orientation)
box1 box2 =
let pos = pos_reduce pos in
let pos2 = match pos2 with
| None -> inverse_pos pos
| Some s -> pos_reduce s in
let [box1;box2] =
if same_height
then same_height [box1;box2]
else [box1;box2] in
let point1 = corner pos box1 in
let point2 = corner pos box2 in
let orient = match orient with
| None -> Point.normalize (Point.sub point1 (ctr box1))
| Some s -> pos_reduce s in
let vec = normalize
*)
(* placement *)
let opposite_position: position -> position = function
| #Types.position as x -> (Types.opposite_position x :> position)
| `Custom f -> `Custom (fun b -> Point.sub (ctr b) (f b))
let place posa ?(pos = opposite_position posa) ?padding a b =
let pa = corner posa a in
let pb = corner pos b in
let c = shift (Point.sub pa pb) b in
match padding with
| None -> c
| Some padding ->
shift (Point.mult padding (normalize (Point.sub pa (ctr a)))) c
(* Boxlike *)
let set_pos = center
mlpost-0.8.2/brush.ml 0000664 0000000 0000000 00000005424 13060465153 0014524 0 ustar 00root root 0000000 0000000 (**************************************************************************)
(* *)
(* Copyright (C) Johannes Kanig, Stephane Lescuyer *)
(* Jean-Christophe Filliatre, Romain Bardou and Francois Bobot *)
(* *)
(* This software is free software; you can redistribute it and/or *)
(* modify it under the terms of the GNU Library General Public *)
(* License version 2.1, with the special exception on linking *)
(* described in file LICENSE. *)
(* *)
(* This software is distributed in the hope that it will be useful, *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *)
(* *)
(**************************************************************************)
open Types
module Pen = Pen
module Dash = struct
include Dash
let scaled = mkDScaled
end
type t = brush
let opt_def def = function
| None -> def
| Some s -> s
let opt_map f = function
| None -> None
| Some s -> Some (f s)
let t color ?(pen) ?(dash) ?(scale) ?(brush) () =
match scale with
| None -> mkBrushOpt brush color pen dash
| Some s ->
mkBrushOpt brush color
(Some (Pen.scale s (opt_def Pen.default pen)))
(opt_map (Dash.scaled s) dash)
(** {2 Predefined Colors} *)
type brush_colored =
?pen:Pen.t -> ?dash:Dash.t -> ?scale:Num.t ->
?brush:t -> unit -> t
(** {3 base colors} *)
let white = t (Some Color.white)
let black = t (Some Color.black)
let red = t (Some Color.red)
let blue = t (Some Color.blue)
let green = t (Some Color.green)
let cyan = t (Some Color.cyan)
let yellow = t (Some Color.yellow)
let magenta = t (Some Color.magenta)
(** {3 lighter colors} *)
let lightred = t (Some Color.lightred)
let lightblue = t (Some Color.lightblue)
let lightgreen = t (Some Color.lightgreen)
let lightcyan = t (Some Color.lightcyan)
let lightyellow = t (Some Color.lightyellow)
let lightmagenta = t (Some Color.lightmagenta)
(** {3 grays} *)
let gray f = t (Some (Color.gray f))
let lightgray = t (Some Color.lightgray)
let mediumgray = t (Some Color.mediumgray)
let darkgray = t (Some Color.darkgray)
(** {3 additional colors} *)
let orange = t (Some Color.orange)
let purple = t (Some Color.purple)
let t ?color = t color
let color t = t.Hashcons.node.color
let pen (t:t) = (t.Hashcons.node.pen : Pen.t option)
let dash t = t.Hashcons.node.dash
mlpost-0.8.2/bugs/ 0000775 0000000 0000000 00000000000 13060465153 0014002 5 ustar 00root root 0000000 0000000 mlpost-0.8.2/bugs/arrows.ml 0000664 0000000 0000000 00000003014 13060465153 0015647 0 ustar 00root root 0000000 0000000 open Mlpost
open Num
open Box
open Command
open Point
open Path
module Co = Color
module P = Pen
module T = Transform
module N = Num
module H = Helpers
let a = -50., -12.5
let b = 0., -50.
let c = 50., -12.5
let d = 0., 50.
let e = 50., 12.5
let g = -50., 12.5
let [b;d] = List.map (fun (x,y) -> x,y+.50.) [b;d]
let l1 = cycle (path ~style:jCurve [a; c; e; g])
let l2 = path ~style:jCurve [b; d]
let l3 = path ~style:jCurve [a; c; e; g;d;b;c]
let d1 =
1,seq [draw l1;draw l2]
let d2 =
2,draw (cut_before l1 l2)
let d3 =
3,draw (cut_before l2 l1)
let d4 =
4,draw (cut_after l1 l2)
let d5 =
5,draw (cut_after l2 l1)
let d6 =
6, Arrow.simple l2
let d7 =
let draw_direction p n =
let po = point n p in
let dir = direction n p in
draw (pathp ~style:jLine [po;add po dir]) in
7, seq [draw l3;
seq (List.map (draw_direction l3)
[0.;1.;2.;2.9;3.;3.1;3.9;4.;4.1;5.;6.])
]
let min = -100.
let max = 100.
let b = (cycle ~style:jLine (path ~style:jLine [(min,min);(max,min);(max,max);(min,max)]))
(* Pour avoir une echelle *)
let embed (id,p) =
id,seq [draw b;p]
let figs = List.map embed
[d1;d2;d3;d4;d5;d6;d7]
let mpostfile = "testmanual"
let cairostfile = "testmanual_cairo"
let texfile = "arrows.tex"
open Format
let _ =
ignore(Sys.command "mkdir -p arrows");
Sys.chdir "arrows";
Metapost.generate mpostfile ~pdf:true figs;
Cairost.generate_pdfs cairostfile figs;
Generate.generate_tex_cairo texfile "testmanual" "testmanual" "testmanual_cairo" figs
mlpost-0.8.2/bugs/contributed2.ml 0000664 0000000 0000000 00000000712 13060465153 0016740 0 ustar 00root root 0000000 0000000 open Mlpost
open Command
open Color
open Box
open Point
open Num
let repository ?wc patches =
let pbox = circle (p (0., 0.)) patches in
let p = draw_box ~fill: green pbox in
let r = match wc with
| None -> p
| Some wc ->
let c = label ~pos: Pbot wc (south pbox) in
draw_box ~fill: yellow (circle (Point.p (0., 0.)) (Picture.make c))
in
[ r ]
let fig =
repository ~wc: (Picture.tex "Copie de travail") (Picture.tex "Patches")
mlpost-0.8.2/bugs/mp/ 0000775 0000000 0000000 00000000000 13060465153 0014416 5 ustar 00root root 0000000 0000000 mlpost-0.8.2/bugs/mp/architecture.ml 0000664 0000000 0000000 00000007526 13060465153 0017444 0 ustar 00root root 0000000 0000000 open Mlpost
open Box
(* Some custom values *)
let padding = Num.bp 15.
let big_padding = Num.bp 30.
let delta = Num.bp 5.
let big_delta = Num.bp 10.
let big_title s = tex ("\\textbf{\\Large{" ^ s ^ "}}")
let small_title s = tex ("\\textbf{\\emph{\\large{" ^ s ^ "}}}")
let external_color = Color.rgb8 255 165 0
let framac_color = Color.rgb8 50 205 50
let plugin_color = Color.lightcyan
let cil_color = Color.rgb8 250 128 114
let std_box ?color s = rect ~name:s ?fill:color (tex s)
let mk_services ?(big=false) ?color title b =
round_rect
?fill:color
~name:title
~dx:padding ~dy:(if big then big_delta else delta)
(vbox ~padding:big_delta
[ (if big then big_title else small_title) title; b ])
let std_plugins =
mk_services
"Standard Plug-ins"
(hbox ~padding
[ std_box "Plug-in 1"; tex "\\dots"; std_box "Plug-in $n$" ])
let kernel_integrated_plugins =
mk_services
"Kernel-integrated Plug-ins"
(hbox ~padding
[ std_box "Plug-in 1"; tex "\\dots"; std_box "Plug-in $p$" ])
let plugins_types =
mk_services
"Kernel-integrated Plug-ins Types"
~color:plugin_color
(hbox ~padding
[ std_box "Plug-in types 1";
tex "\\dots";
std_box "Plug-in types $q$" ])
let kernel_frontend =
mk_services ~color:framac_color
"Plug-ins Values"
(hbox ~padding [ std_box ~color:plugin_color "Db"; std_box "Dynamic" ])
let kernel_specific_services =
mk_services
"Specific Services"
(vbox ~padding
[ hbox ~padding [ std_box "AST Manipulation"; std_box "Memory States" ];
std_box "Abstract Interpretation Lattices";
std_box "Utilities" ])
let kernel_general_services =
mk_services
"General Services"
(vbox ~padding
[
std_box "Project";
hbox ~padding [std_box "Plugin"; std_box "Journal" ];
std_box "Cmdline";
hbox ~padding [ std_box "Type"; std_box "Log" ]
])
let cil =
mk_services ~color:cil_color
"Extended Cil"
(vbox ~padding
[ std_box "Extended Cil API";
rect ~name:"Cil Kernel" (vbox [ tex "Extended Cil Kernel";
tex "Lexing, Parsing, Typing, Linking" ]);
std_box "Extended Cil AST" ])
let figure =
vbox ~padding:big_padding
[
mk_services ~big:true "Plug-ins" ~color:plugin_color
(hbox ~padding:big_padding [ std_plugins; kernel_integrated_plugins ]);
mk_services ~big:true ~color:framac_color
"Plug-ins API inside Frama-C"
(hbox ~padding:big_padding [ kernel_frontend; plugins_types ]);
mk_services ~big:true "Frama-C Kernel" ~color:framac_color
(hbox ~padding:big_padding
[ kernel_specific_services; kernel_general_services ]);
cil
]
let arrow ?(big=false) src dst =
let getf s = get s figure in
let src = getf src in
let dst = getf dst in
if big then Helpers.box_arrow ~color:Color.red ~pen:Pen.circle src dst
else Helpers.box_arrow src dst
let cmds =
Command.seq
[
draw figure;
(* Kernel Specific Services *)
(*
arrow "AST Manipulation" "Abstract Interpretation Lattices";
arrow "Memory States" "Abstract Interpretation Lattices";
arrow "Abstract Interpretation Lattices" "Utilities";
(* Kernel General Services *)
arrow "Project" "Journal"; arrow "Journal" "Cmdline";
arrow "Cmdline" "Type"; arrow "Plugin" "Cmdline";
arrow "Cmdline" "Log";
(* Extended Cil *)
arrow "Extended Cil API" "Cil Kernel";
arrow "Cil Kernel" "Extended Cil AST";
(* inter-services arrow *)
arrow ~big:true "Plug-ins" "Plug-ins API inside Frama-C";
arrow ~big:true "Plug-ins Values" "Kernel-integrated Plug-ins Types";
arrow ~big:true "Plug-ins API inside Frama-C" "Frama-C Kernel";
arrow ~big:true "Specific Services" "General Services";
arrow ~big:true "Specific Services" "Extended Cil";
arrow ~big:true "Extended Cil" "General Services" ;
*)
]
let _ = Metapost.emit "architecture" cmds
mlpost-0.8.2/bugs/mp/integrated_plugin.ml 0000664 0000000 0000000 00000017536 13060465153 0020470 0 ustar 00root root 0000000 0000000 open Mlpost
open Box
(* Some custom values *)
let padding = Num.bp 15.
let delta = Num.bp 10.
let unused = "$^\\star$"
let big_title s = "\\textbf{\\Large{" ^ s ^ "}}"
let small_title s = "\\textbf{\\large{" ^ s ^ "}}"
let external_color = Color.rgb8 255 165 0
let internal_color = Color.rgb8 50 205 50
let plugin_color = Color.lightcyan
let make_color = Color.rgb8 250 128 114
let intf_color = Color.rgb8 46 139 97
(* Some very useful functions: should be in some way in the mlpost API? *)
let box_width ?name ?style ?fill ?dy w b =
box ?name ?style ?fill ?dy ~dx:(Num.divf (Num.subn w (width b)) 2.) b
let box_height ?name ?style ?fill ?dx h b =
box ?name ?style ?fill ?dx ~dy:(Num.divf (Num.subn h (height b)) 2.) b
let box_hw ?name ?style ?fill h b =
box ?name ?style ?fill
~dx:(Num.divf (Num.subn h (width b)) 2.)
~dy:(Num.divf (Num.subn h (height b)) 2.) b
let vbox_same_width ?name ?padding ~style l =
let max = List.fold_left (fun acc b -> Num.maxn acc (width b)) Num.zero l in
vbox ?name ?padding
(List.map
(fun b -> box_width max
~style
?fill:(get_fill b)
~dy:Num.zero
(clear_stroke b))
l)
let simulate_box ?name b = empty ?name ~width:(width b) ~height:(height b) ()
let xmed ?(coef=0.5) p1 p2 =
Num.multf coef (Num.addn (Point.xpart p1) (Point.xpart p2))
let ymed ?(coef=0.5) p1 p2 =
Num.multf coef (Num.addn (Point.ypart p1) (Point.ypart p2))
let med ?xcoef ?ycoef p1 p2 =
Point.pt (xmed ?coef:xcoef p1 p2, ymed ?coef:ycoef p1 p2)
(* Some special functions for this figure *)
let modul ?(color=external_color) ?same_height ?same_width s =
let t = tex s in
match same_height, same_width with
| None, None -> box ~name:s ~fill:color ~style:Rect t
| Some h, None -> box_height ~name:s ~fill:color ~style:Rect h t
| None, Some w -> box_width ~name:s ~fill:color ~style:Rect w t
| Some h, Some w ->
assert (h = w);
box_hw ~name:s ~fill:color ~style:Rect w t
(* The figure itself *)
let fig =
(* special external modules: Makefile.in + Design *)
let design =
rect ~fill:external_color ~name:"design"
(vbox [ tex ("Design" ^ unused); tex "(GUI extension point)" ])
in
let std_modul = modul ~same_height:(height design) in
(* empty modules *)
let empty_modules ?(color=internal_color) () =
let empty_module = std_modul ~color ~same_width:(height design) "" in
let points = tex "\\dots" in
hbox ~padding [ empty_module; points; empty_module ]
in
let makein = std_modul ~color:make_color "Makefile.in" in
let configurein = std_modul ~color:make_color "configure.in" in
let autotools = hbox ~padding [ makein; configurein ] in
let tests =
round_rect ~name:"tests" ~fill:plugin_color ~dx:padding ~dy:delta
(vbox ~padding:delta
[ tex (small_title "Plug-in tests suite");
empty_modules ~color:plugin_color () ])
in
let types =
round_rect ~fill:intf_color ~dx:padding ~dy:delta
(vbox ~padding:delta
[ tex (small_title ("Plug-in types" ^ unused));
empty_modules ~color:intf_color () ])
in
(* Plug-in implem *)
let title = tex (small_title "Plug-in implementation") in
let register = std_modul ~color:internal_color "Register" in
let options = std_modul ~color:internal_color "Options" in
let b = vbox_same_width ~padding:delta ~style:Rect [ register; options ] in
let b = vbox ~padding:delta [ title; b; empty_modules () ] in
let implem =
round_rect ~name:"implem" ~fill:internal_color ~dx:delta ~dy:delta b
in
(* Plug-in GUI *)
let gui = tex (small_title "Plug-in GUI$^\\star$") in
let gui =
round_rect ~name:"gui" ~dx:delta ~dy:(Num.addn delta (Num.divf padding 2.))
~fill:internal_color
(vbox ~padding:delta [ gui; empty_modules () ])
in
(* Makefile *)
let makefile =
let t = tex (small_title "Empty plug-in interface") in
box_height
~name:"makefile"
~style:RoundRect
~fill:intf_color
(Num.subn (height implem) (Num.addn (height gui) padding))
t
in
(* Makefile + Plug-in GUI *)
let right_box =
vbox_same_width ~name:"right" ~padding ~style:RoundRect [ makefile; gui ]
in
(* left column *)
let db_main = std_modul "Db.Main" in
let db = std_modul "Db" in
let journal = std_modul ("Journal" ^ unused) in
let plugin = std_modul "Plugin" in
let prj = std_modul ("Project" ^ unused) in
let typ = std_modul ("Type" ^ unused) in
let left_box =
vbox_same_width ~padding ~style:Rect
[ db; db_main; plugin; typ; journal; prj ]
in
(* setting the components as a matrix *)
let figure =
hbox ~padding:(Num.multf 3. padding)
[
left_box;
tabularl ~hpadding:padding ~vpadding:(Num.multf 3. padding)
[
[ tests; autotools ];
[ simulate_box ~name:"ei" implem;
simulate_box ~name:"er" right_box ];
[ types; design ]
]
]
in
let getf s = get s figure in
(* add the Plug-in directory and merge it in the matrix *)
let nwp = north_west (getf "ei") in
let sep = south_east (getf "er") in
let main_box = hbox ~padding [ implem; right_box ] in
let title = tex (big_title "Plug-in directory") in
let b = vbox ~padding:delta [ title; main_box ] in
let directory_box =
let r = round_rect ~fill:plugin_color ~dx:padding ~dy:delta b in
center (med nwp sep) r
in
(* caption *)
let caption =
tabularl ~pos:`Right ~hpadding:delta
[
[ tex "\\textbf{Caption:}"; empty () ];
[ tex "$\\star$"; tex "part not covered in this tutorial" ];
[ hbox ~padding [ empty ~name:"c1" (); empty ~name:"c2" () ];
tex "registration points through hooks" ];
[ hbox ~padding [ empty ~name:"c3" (); empty ~name:"c4" () ];
tex "insertion points directly into the pointed file" ]
]
in
let full_box = vbox ~padding ~pos:` Right [ figure; caption ] in
let draw_arrow ?(insert=false) l =
let p = Path.pathp ~style:Path.jLine l in
if insert then Arrow.simple ~color:Color.red ~pen:Pen.circle p
else Arrow.simple p
in
let arrow ?insert pos src dst =
let p1, p2 = match pos with
| `West ->
let p2 = west dst in
Point.pt (Point.xpart (east src), Point.ypart p2), p2
| `East ->
let p2 = east dst in
Point.pt (Point.xpart (west src), Point.ypart p2), p2
| `South ->
let p2 = south dst in
Point.pt (Point.xpart p2, Point.ypart (north src)), p2
| `North ->
let p2 = north dst in
Point.pt (Point.xpart p2, Point.ypart (south src)), p2
in
draw_arrow ?insert [ p1; p2 ]
in
let third_arrow coef ?insert ?(yscale=1.) src dst =
let p1 = Point.yscale (Num.bp yscale) (west src) in
let p4 = (*east dst*) (* JS: don't know why it doesn't work *)
Point.pt (Point.xpart (east left_box), Point.ypart (east dst))
in
let x = xmed ~coef p1 p4 in
let p2 = Point.pt (x, Point.ypart p1) in
let p3 = Point.pt (x, Point.ypart p4) in
(* Why [Arrow.draw] does not provide the same result? *)
draw_arrow ?insert [ p1; p2; p3; p4 ]
in
let getf s = get s full_box in
Command.seq
[
draw full_box;
draw directory_box;
arrow `East (getf "c1") (getf "c2");
arrow ~insert:true `East (getf "c3") (getf "c4");
arrow `North (get "gui" directory_box) (getf "design");
arrow ~insert:true `West (getf "tests") (getf "Makefile.in");
arrow ~insert:true `South directory_box (getf "Makefile.in");
arrow ~insert:true `South directory_box (getf "configure.in");
third_arrow ~insert:true 0.5 ~yscale:0.3 directory_box (getf "Db");
third_arrow 0.29 (get "Options" directory_box) (getf "Plugin");
third_arrow 0.32 (get "Register" directory_box) (getf "Db.Main");
third_arrow 0.4 ~yscale:1.23
(get "implem" directory_box) (getf ("Journal" ^ unused));
third_arrow 0.4 ~yscale:1.23
(get "implem" directory_box) (getf ("Type" ^ unused));
third_arrow 0.55 ~yscale:1.5 directory_box (getf ("Project" ^ unused));
]
let _ = Metapost.emit "integrated_plugin" fig
mlpost-0.8.2/bugs/mp/makefiles.ml 0000664 0000000 0000000 00000005037 13060465153 0016715 0 ustar 00root root 0000000 0000000 open Mlpost
open Box
(* Some custom values *)
let small_padding = Num.bp 20.
let padding = Num.bp 50.
let delta = Num.bp 5.
let big_title s = tex ("\\textbf{\\Large{" ^ s ^ "}}")
let small_title s = tex ("\\textbf{\\emph{\\large{" ^ s ^ "}}}")
let plugin_color = Color.rgb8 255 165 0
let framac_color = Color.rgb8 50 205 50
(*let plugin_color = Color.lightcyan*)
let cil_color = Color.rgb8 250 128 114
let std_box color name s =
round_rect ~name ~fill:color ~dx:delta ~dy:delta (tex s)
let config = std_box framac_color "config" "Makefile.config.in"
let framac = std_box framac_color "framac" "Makefile.in"
let plugin = std_box framac_color "plugin" "Makefile.plugin"
let dynamic = std_box framac_color "dynamic" "Makefile.dynamic"
let spec1 = std_box plugin_color "spec1" "specific Makefile for plug-in 1"
let dots = tex ~name:"dots" "$\\dots$"
let specn = std_box plugin_color "specn" "specific Makefile for plug-in $n$"
let spec_box = hbox ~padding:small_padding [ spec1; dots; specn ]
let box0 = hbox ~padding:small_padding [ framac; dots; plugin ]
let box1 = hbox ~padding [ box0; dynamic ]
let caption =
tabularl ~pos:`Right ~hpadding:delta
[
[ tex "\\textbf{Caption:}"; empty () ];
[ hbox ~padding:small_padding
[ tex ~name:"m1" "$m1$"; tex ~name:"m2" "$m2$" ];
tex "Makefile $m1$ is included into Makefile $m2$" ]
]
let gen_box = vbox ~padding [ config; box1; spec_box ]
let full_box = vbox ~padding:small_padding ~pos:`Right [ gen_box; caption ]
let arrow ?outd ?style ?color src dst =
let getf s = get s full_box in
let src = getf src in
let dst = getf dst in
Helpers.box_arrow ?outd ?style ?color ~pen:Pen.circle src dst
let plugin_fc scale =
let p1 = west (get "plugin" full_box) in
let p2 = east (get "framac" full_box) in
let p3 = Point.segment 0.33 p1 p2 in
let p4 = Point.segment 0.66 p1 p2 in
let p3 = Point.yscale (Num.bp scale) p3 in
let p4 = Point.yscale (Num.bp scale) p4 in
arrow
(* ~outd:(Path.vec p3 p4)*)
~style:(Path.jControls p3 p4)
~color:plugin_color
"plugin"
"framac"
let cmds =
Command.seq
[
draw full_box;
arrow ~color:framac_color "config" "framac";
arrow ~color:framac_color "config" "dynamic";
arrow ~color:framac_color "plugin" "dynamic";
arrow ~color:plugin_color "dynamic" "spec1";
(* arrow "dynamic" "dots";*)
arrow ~color:plugin_color "dynamic" "specn";
(* arrow plugin_color "plugin" "framac";*)
plugin_fc 0.8;
plugin_fc 1.2;
arrow "m1" "m2"
]
let _ = Metapost.emit "makefiles" cmds
mlpost-0.8.2/bugs/mp/plugin.ml 0000664 0000000 0000000 00000014572 13060465153 0016257 0 ustar 00root root 0000000 0000000 open Mlpost
open Box
(* Some custom values *)
let padding = Num.bp 15.
let delta = Num.bp 10.
let unused = "$^\\star$"
let big_title s = "\\textbf{\\Large{" ^ s ^ "}}"
let small_title s = "\\textbf{\\large{" ^ s ^ "}}"
let external_color = Color.rgb8 255 165 0
let internal_color = Color.rgb8 50 205 50
let plugin_color = Color.lightcyan
let make_color = (*Color.rgb8 46 139 97*) Color.rgb8 250 128 114
(* Some very useful functions: should be in some way in the mlpost API? *)
let box_width ?name ?style ?fill ?dy w b =
box ?name ?style ?fill ?dy ~dx:(Num.divf (Num.subn w (width b)) 2.) b
let box_height ?name ?style ?fill ?dx h b =
box ?name ?style ?fill ?dx ~dy:(Num.divf (Num.subn h (height b)) 2.) b
let box_hw ?name ?style ?fill h b =
box ?name ?style ?fill
~dx:(Num.divf (Num.subn h (width b)) 2.)
~dy:(Num.divf (Num.subn h (height b)) 2.) b
let vbox_same_width ?name ?padding ~style l =
let max = List.fold_left (fun acc b -> Num.maxn acc (width b)) Num.zero l in
vbox ?name ?padding
(List.map
(fun b -> box_width max
~style
?fill:(get_fill b)
~dy:Num.zero
(clear_stroke b))
l)
let simulate_box ?name b = empty ?name ~width:(width b) ~height:(height b) ()
let xmed ?(coef=0.5) p1 p2 =
Num.multf coef (Num.addn (Point.xpart p1) (Point.xpart p2))
let ymed ?(coef=0.5) p1 p2 =
Num.multf coef (Num.addn (Point.ypart p1) (Point.ypart p2))
let med ?xcoef ?ycoef p1 p2 =
Point.pt (xmed ?coef:xcoef p1 p2, ymed ?coef:ycoef p1 p2)
(* Some special functions for this figure *)
let modul ?(color=external_color) ?same_height ?same_width s =
let t = tex s in
match same_height, same_width with
| None, None -> box ~name:s ~fill:color ~style:Rect t
| Some h, None -> box_height ~name:s ~fill:color ~style:Rect h t
| None, Some w -> box_width ~name:s ~fill:color ~style:Rect w t
| Some h, Some w ->
assert (h = w);
box_hw ~name:s ~fill:color ~style:Rect w t
(* The figure itself *)
let fig =
(* special external modules: Makefile.dynamic + Design *)
let design =
rect ~fill:external_color ~name:"design"
(vbox [ tex ("Design" ^ unused); tex "(GUI extension point)" ])
in
let std_modul = modul ~same_height:(height design) in
let dynmake = std_modul ~color:make_color "Makefile.dynamic" in
(* empty modules *)
let empty_modules =
let empty_module =
std_modul ~color:internal_color ~same_width:(height design) ""
in
let points = tex "\\dots" in
hbox ~padding [ empty_module; points; empty_module ]
in
(* Plug-in implem *)
let title = tex (small_title "Plug-in implementation") in
let register = std_modul ~color:internal_color "Register" in
let options = std_modul ~color:internal_color "Options" in
let b = vbox_same_width ~padding:delta ~style:Rect [ register; options ] in
let b = vbox ~padding:delta [ title; b; empty_modules ] in
let implem =
round_rect ~name:"implem" ~fill:internal_color ~dx:delta ~dy:delta b
in
(* Plug-in GUI *)
let gui = tex (small_title "Plug-in GUI$^\\star$") in
let gui =
round_rect ~name:"gui" ~dx:delta ~dy:(Num.addn delta (Num.divf padding 2.))
~fill:internal_color
(vbox ~padding:delta [ gui; empty_modules ])
in
(* Makefile *)
let makefile =
let t = tex "\\large{Makefile}" in
box_height
~name:"makefile"
~style:RoundRect
~fill:make_color
(Num.subn (height implem) (Num.addn (height gui) padding))
t
in
(* Makefile + Plug-in GUI *)
let right_box =
vbox_same_width ~name:"right" ~padding ~style:RoundRect [ makefile; gui ]
in
(* left column *)
let db = std_modul "Db.Main" in
let dyn = std_modul ("Dynamic" ^ unused) in
let journal = std_modul ("Journal" ^ unused) in
let plugin = std_modul "Plugin" in
let prj = std_modul ("Project" ^ unused) in
let typ = std_modul ("Type" ^ unused) in
let left_box =
vbox_same_width ~padding ~style:Rect
[ db; dyn; plugin; typ; journal; prj ]
in
(* setting the components as a matrix *)
let figure =
hbox ~padding:(Num.multf 3. padding)
[
left_box;
tabularl ~hpadding:padding ~vpadding:(Num.multf 3. padding)
[
[ empty (); dynmake ];
[ simulate_box ~name:"ei" implem;
simulate_box ~name:"er" right_box ];
[ empty (); design ]
]
]
in
let getf s = get s figure in
(* add the Plug-in directory and merge it in the matrix *)
let nwp = north_west (getf "ei") in
let sep = south_east (getf "er") in
let main_box = hbox ~padding [ implem; right_box ] in
let title = tex (big_title "Plug-in directory") in
let b = vbox ~padding:delta [ title; main_box ] in
let directory_box =
let r = round_rect ~fill:plugin_color ~dx:padding ~dy:delta b in
center (med nwp sep) r
in
(* caption *)
let caption =
tabularl ~pos:`Right ~hpadding:delta
[
[ tex "\\textbf{Caption:}"; empty () ];
[ tex "$\\star$"; tex "part not covered in this tutorial" ];
[ hbox ~padding [ empty ~name:"c1" (); empty ~name:"c2" () ];
tex "registration points" ]
]
in
let full_box = vbox ~padding ~pos:` Right [ figure; caption ] in
let arrow src dst = Helpers.box_arrow src dst in
let third_arrow coef ?(yscale=1.) src dst =
let p1 = Point.yscale (Num.bp yscale) (west src) in
let p4 = (*east dst*) (* JS: don't know why it doesn't work *)
Point.pt (Point.xpart (east left_box), Point.ypart (east dst))
in
let x = xmed ~coef p1 p4 in
let p2 = Point.pt (x, Point.ypart p1) in
let p3 = Point.pt (x, Point.ypart p4) in
(* Why [Arrow.draw] does not provide the same result? *)
Arrow.simple (Path.pathp ~style:Path.jLine [ p1; p2; p3; p4 ])
in
let getf s = get s full_box in
Command.seq
[
draw full_box;
draw directory_box;
arrow (getf "c1") (getf "c2");
arrow (get "gui" directory_box) (getf "design");
arrow (get "makefile" directory_box) (getf "Makefile.dynamic");
third_arrow 0.32 (get "Options" directory_box) (getf "Plugin");
third_arrow
0.35 (get "Register" directory_box) (getf ("Dynamic" ^ unused));
third_arrow 0.35 (get "Register" directory_box) (getf "Db.Main");
third_arrow 0.4 ~yscale:1.23
(get "implem" directory_box) (getf ("Journal" ^ unused));
third_arrow 0.4 ~yscale:1.23
(get "implem" directory_box) (getf ("Type" ^ unused));
third_arrow 0.55 ~yscale:1.5 directory_box (getf ("Project" ^ unused));
]
let _ = Metapost.emit "plugin" fig
mlpost-0.8.2/cairost.ml 0000664 0000000 0000000 00000006545 13060465153 0015052 0 ustar 00root root 0000000 0000000 (**************************************************************************)
(* *)
(* Copyright (C) Johannes Kanig, Stephane Lescuyer *)
(* Jean-Christophe Filliatre, Romain Bardou and Francois Bobot *)
(* *)
(* This software is free software; you can redistribute it and/or *)
(* modify it under the terms of the GNU Library General Public *)
(* License version 2.1, with the special exception on linking *)
(* described in file LICENSE. *)
(* *)
(* This software is distributed in the hope that it will be useful, *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *)
(* *)
(**************************************************************************)
IFDEF CAIRO THEN
let supported = true
module M = Mps
open Icairost
let emit_pdf = emit_pdf
let emit_ps = emit_ps
let emit_png = emit_png
let emit_svg = emit_svg
let emit_pdfs = emit_pdfs
type cairo_t = Cairo.t
let emit_cairo = emit_cairo
(*let emit_cairo = fun x -> ()*)
let dump_pdf () =
Queue.iter (fun (fname,fig) ->
let pdfname = File.mk fname "pdf" in
let pdfname_s = File.to_string pdfname in
try emit_pdf pdfname_s fig
with
| Cairo.Error status ->
Format.printf "An@ internal@ error@ occured@ during@ the\
generation@ of@ %s@ with@ Cairo :@ %s@."
pdfname_s (Cairo.string_of_status status)
| error ->
Format.printf "An@ internal@ error@ occured@ during@ the\
@ generation@ of@ %s :@ %s@."
pdfname_s (Printexc.to_string error)
) Defaults.figures
let dump_pdfs fname =
let figs =
List.rev (Queue.fold (fun l (_,x) -> x::l) [] Defaults.figures) in
emit_pdfs (fname^".pdf") figs
let generate_pdfs pdffile figs = List.iter
(fun (i,fig) -> emit_pdf ~msg_error:100.
(Printf.sprintf "%s-%i.pdf" pdffile i) fig) figs
let dump_ext ext f () =
Queue.iter (fun (fname,fig) ->
let s = File.to_string (File.mk fname ext) in
f s fig) Defaults.figures
let dump_ps = dump_ext "ps" emit_ps
let dump_png = dump_ext "png" emit_png
let dump_svg = dump_ext "svg" emit_svg
ELSE
let supported = false
let float_of_num n = failwith "Cairost.float_of_num : not supported"
let emit_pdf ?msg_error s c = failwith "Cairost.emit_pdf: not supported"
let emit_png s c = failwith "Cairost.emit_png: not supported"
let emit_ps s c = failwith "Cairost.emit_ps: not supported"
let emit_svg s c = failwith "Cairost.emit_svg: not supported"
let emit_pdfs s c = failwith "Cairost.emit_pdfs: not supported"
let dump_pdf _ = failwith "Cairost.dump_pdf : not supported"
let dump_pdfs _ = failwith "Cairost.dump_pdfs : not supported"
let dump_ps _ = failwith "Cairost.dump_ps : not supported"
let dump_png _ = failwith "Cairost.dump_png : not supported"
let dump_svg _ = failwith "Cairost.dump_svg : not supported"
let generate_pdfs _ _ = failwith "Cairost.generate_pdfs : not supported"
type cairo_t = unit
let emit_cairo _ _ _ = failwith "Cairost.emit_cairo : not supported"
END
mlpost-0.8.2/color.ml 0000664 0000000 0000000 00000135626 13060465153 0014527 0 ustar 00root root 0000000 0000000 (**************************************************************************)
(* *)
(* Copyright (C) Johannes Kanig, Stephane Lescuyer *)
(* Jean-Christophe Filliatre, Romain Bardou and Francois Bobot *)
(* *)
(* This software is free software; you can redistribute it and/or *)
(* modify it under the terms of the GNU Library General Public *)
(* License version 2.1, with the special exception on linking *)
(* described in file LICENSE. *)
(* *)
(* This software is distributed in the hope that it will be useful, *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *)
(* *)
(**************************************************************************)
open Concrete_types
type st = Concrete_types.scolor =
| RGB of float * float * float
| CMYK of float * float * float * float
| Gray of float
type t = Concrete_types.color =
|OPAQUE of scolor
|TRANSPARENT of float * scolor
let rgb8 r g b =
OPAQUE (RGB ((float r)/.255., (float g)/.255., (float b)/.255.))
let rgb8a r g b a =
TRANSPARENT ((float a)/.255.,
RGB ((float r)/.255., (float g)/.255., (float b)/.255.))
let rgb_from_int i =
let b = i land 0xFF in
let g = (i land 0xFF00) lsr 8 in
let r = (i land 0xFF0000) lsr 16 in
rgb8 r g b
(* http://en.wikipedia.org/wiki/HSL_and_HSV *)
let hsv h s v =
assert (0.<= s && s<=1.);
assert (0.<= v && v<=1.);
let c = v *. s in
let h' = h /. 60. in
let x = c *. (1. -. (abs_float ((mod_float h' 2.) -. 1.))) in
let (r_1, g_1, b_1) =
if 0. <= h' && h' < 1. then (c,x,0.)
else if 1. <= h' && h' < 2. then (x,c,0.)
else if 2. <= h' && h' < 3. then (0.,c,x)
else if 3. <= h' && h' < 4. then (0.,x,c)
else if 4. <= h' && h' < 5. then (x,0.,c)
else if 5. <= h' && h' < 6. then (c,0.,x)
else (0.,0.,0.) in
let m = v -. c in
OPAQUE (RGB (r_1 +. m, g_1 +. m, b_1 +. m))
let color_gen s v =
let choices = ref [] in
let value = 180. in
let next = ref 0. in
fun () ->
let rec aux acc value current = function
| [] ->
assert (current = 0.);
next := value;
List.rev_append acc [true]
| true::l ->
aux (false::acc) (value/.2.) (current-.value) l
| false::l ->
next := current +. value;
List.rev_append acc (true::l) in
let res = !next in
choices := aux [] value res !choices;
hsv res s v
let red = OPAQUE (RGB (1.0,0.0,0.0))
let lightred = OPAQUE (RGB (1.0,0.5,0.5))
let blue = OPAQUE (RGB (0.0,0.0,1.0))
let lightblue = rgb_from_int 0xADD8E6
let green = rgb_from_int 0x008000
let lightgreen = rgb_from_int 0x90EE90
let orange = rgb_from_int 0xFFA500
let purple = rgb_from_int 0x7F007F
let magenta = OPAQUE (RGB (1.0,0.0,1.0))
let cyan = OPAQUE (RGB (0.0,1.0,1.0))
let lightcyan = rgb_from_int 0xE0FFFF
let yellow = OPAQUE (RGB (1.0,1.0,0.0))
let lightyellow = rgb_from_int 0xFFFFE0
(* these colors do not correspond to neither X11 nor HTML colors
- commented out*)
(* let lightblue = OPAQUE (RGB (0.5,0.5,1.0)) *)
(* let green = OPAQUE (RGB (0.0,1.0,0.0)) *)
(* let lightgreen = OPAQUE (RGB (0.5,1.0,0.5)) *)
(* let orange = OPAQUE (RGB (1.0,0.4,0.0)) *)
(* let purple = OPAQUE (RGB (0.6,0.0,0.6)) *)
(* let lightcyan = OPAQUE (RGB (0.5,1.0,1.0)) *)
(* let lightyellow = OPAQUE (RGB (1.0,1.0,0.5)) *)
let lightmagenta = OPAQUE (RGB (1.0,0.5,1.0))
let gray f = OPAQUE (Gray f)
let white = gray 1.0
let lightgray = gray 0.75
let mediumgray = gray 0.5
let darkgray = gray 0.25
let black = gray 0.0
let default = black
let rgb r g b = OPAQUE (RGB (r,g,b))
let rgba r g b a = TRANSPARENT (a,RGB (r,g,b))
let cmyk c m y k = OPAQUE (CMYK (c,m,y,k))
let cmyka c m y k a = TRANSPARENT (a,CMYK (c,m,y,k))
let is_opaque = function |OPAQUE _ -> true | _ -> false
let opaque = function |TRANSPARENT (_,c) -> OPAQUE c | c -> c
let transparent f = function
|TRANSPARENT (f2,c) -> TRANSPARENT (f*.f2,c)
|OPAQUE c -> TRANSPARENT (f,c)
let colors : (string, t) Hashtbl.t = Hashtbl.create 91
let color n = Hashtbl.find colors n
(** generated part *)
let _ = Hashtbl.add colors "snow" (rgb8 255 250 250)
let _ = Hashtbl.add colors "ghost" (rgb8 248 248 255)
let _ = Hashtbl.add colors "GhostWhite" (rgb8 248 248 255)
let _ = Hashtbl.add colors "white smoke" (rgb8 245 245 245)
let _ = Hashtbl.add colors "WhiteSmoke" (rgb8 245 245 245)
let _ = Hashtbl.add colors "gainsboro" (rgb8 220 220 220)
let _ = Hashtbl.add colors "floral white" (rgb8 255 250 240)
let _ = Hashtbl.add colors "FloralWhite" (rgb8 255 250 240)
let _ = Hashtbl.add colors "old lace" (rgb8 253 245 230)
let _ = Hashtbl.add colors "OldLace" (rgb8 253 245 230)
let _ = Hashtbl.add colors "linen" (rgb8 250 240 230)
let _ = Hashtbl.add colors "antique white" (rgb8 250 235 215)
let _ = Hashtbl.add colors "AntiqueWhite" (rgb8 250 235 215)
let _ = Hashtbl.add colors "papaya whip" (rgb8 255 239 213)
let _ = Hashtbl.add colors "PapayaWhip" (rgb8 255 239 213)
let _ = Hashtbl.add colors "blanched almond" (rgb8 255 235 205)
let _ = Hashtbl.add colors "BlanchedAlmond" (rgb8 255 235 205)
let _ = Hashtbl.add colors "bisque" (rgb8 255 228 196)
let _ = Hashtbl.add colors "peach puff" (rgb8 255 218 185)
let _ = Hashtbl.add colors "PeachPuff" (rgb8 255 218 185)
let _ = Hashtbl.add colors "navajo white" (rgb8 255 222 173)
let _ = Hashtbl.add colors "NavajoWhite" (rgb8 255 222 173)
let _ = Hashtbl.add colors "moccasin" (rgb8 255 228 181)
let _ = Hashtbl.add colors "cornsilk" (rgb8 255 248 220)
let _ = Hashtbl.add colors "ivory" (rgb8 255 255 240)
let _ = Hashtbl.add colors "lemon chiffon" (rgb8 255 250 205)
let _ = Hashtbl.add colors "LemonChiffon" (rgb8 255 250 205)
let _ = Hashtbl.add colors "seashell" (rgb8 255 245 238)
let _ = Hashtbl.add colors "honeydew" (rgb8 240 255 240)
let _ = Hashtbl.add colors "mint cream" (rgb8 245 255 250)
let _ = Hashtbl.add colors "MintCream" (rgb8 245 255 250)
let _ = Hashtbl.add colors "azure" (rgb8 240 255 255)
let _ = Hashtbl.add colors "alice blue" (rgb8 240 248 255)
let _ = Hashtbl.add colors "AliceBlue" (rgb8 240 248 255)
let _ = Hashtbl.add colors "lavender" (rgb8 230 230 250)
let _ = Hashtbl.add colors "lavender blush" (rgb8 255 240 245)
let _ = Hashtbl.add colors "LavenderBlush" (rgb8 255 240 245)
let _ = Hashtbl.add colors "misty rose" (rgb8 255 228 225)
let _ = Hashtbl.add colors "MistyRose" (rgb8 255 228 225)
let _ = Hashtbl.add colors "white" (rgb8 255 255 255)
let _ = Hashtbl.add colors "black" (rgb8 0 0 0)
let _ = Hashtbl.add colors "dark slate gray" (rgb8 47 79 79)
let _ = Hashtbl.add colors "DarkSlateGray" (rgb8 47 79 79)
let _ = Hashtbl.add colors "dark slate grey" (rgb8 47 79 79)
let _ = Hashtbl.add colors "DarkSlateGrey" (rgb8 47 79 79)
let _ = Hashtbl.add colors "dim gray" (rgb8 105 105 105)
let _ = Hashtbl.add colors "DimGray" (rgb8 105 105 105)
let _ = Hashtbl.add colors "dim grey" (rgb8 105 105 105)
let _ = Hashtbl.add colors "DimGrey" (rgb8 105 105 105)
let _ = Hashtbl.add colors "slate gray" (rgb8 112 128 144)
let _ = Hashtbl.add colors "SlateGray" (rgb8 112 128 144)
let _ = Hashtbl.add colors "slate grey" (rgb8 112 128 144)
let _ = Hashtbl.add colors "SlateGrey" (rgb8 112 128 144)
let _ = Hashtbl.add colors "light slate gray" (rgb8 119 136 153)
let _ = Hashtbl.add colors "LightSlateGray" (rgb8 119 136 153)
let _ = Hashtbl.add colors "light slate grey" (rgb8 119 136 153)
let _ = Hashtbl.add colors "LightSlateGrey" (rgb8 119 136 153)
let _ = Hashtbl.add colors "gray" (rgb8 190 190 190)
let _ = Hashtbl.add colors "grey" (rgb8 190 190 190)
let _ = Hashtbl.add colors "light grey" (rgb8 211 211 211)
let _ = Hashtbl.add colors "LightGrey" (rgb8 211 211 211)
let _ = Hashtbl.add colors "light gray" (rgb8 211 211 211)
let _ = Hashtbl.add colors "LightGray" (rgb8 211 211 211)
let _ = Hashtbl.add colors "midnight blue" (rgb8 25 25 112)
let _ = Hashtbl.add colors "MidnightBlue" (rgb8 25 25 112)
let _ = Hashtbl.add colors "navy" (rgb8 0 0 128)
let _ = Hashtbl.add colors "navy blue" (rgb8 0 0 128)
let _ = Hashtbl.add colors "NavyBlue" (rgb8 0 0 128)
let _ = Hashtbl.add colors "cornflower blue" (rgb8 100 149 237)
let _ = Hashtbl.add colors "CornflowerBlue" (rgb8 100 149 237)
let _ = Hashtbl.add colors "dark slate blue" (rgb8 72 61 139)
let _ = Hashtbl.add colors "DarkSlateBlue" (rgb8 72 61 139)
let _ = Hashtbl.add colors "slate blue" (rgb8 106 90 205)
let _ = Hashtbl.add colors "SlateBlue" (rgb8 106 90 205)
let _ = Hashtbl.add colors "medium slate blue" (rgb8 123 104 238)
let _ = Hashtbl.add colors "MediumSlateBlue" (rgb8 123 104 238)
let _ = Hashtbl.add colors "light slate blue" (rgb8 132 112 255)
let _ = Hashtbl.add colors "LightSlateBlue" (rgb8 132 112 255)
let _ = Hashtbl.add colors "medium blue" (rgb8 0 0 205)
let _ = Hashtbl.add colors "MediumBlue" (rgb8 0 0 205)
let _ = Hashtbl.add colors "royal blue" (rgb8 65 105 225)
let _ = Hashtbl.add colors "RoyalBlue" (rgb8 65 105 225)
let _ = Hashtbl.add colors "blue" (rgb8 0 0 255)
let _ = Hashtbl.add colors "dodger blue" (rgb8 30 144 255)
let _ = Hashtbl.add colors "DodgerBlue" (rgb8 30 144 255)
let _ = Hashtbl.add colors "deep sky blue" (rgb8 0 191 255)
let _ = Hashtbl.add colors "DeepSkyBlue" (rgb8 0 191 255)
let _ = Hashtbl.add colors "sky blue" (rgb8 135 206 235)
let _ = Hashtbl.add colors "SkyBlue" (rgb8 135 206 235)
let _ = Hashtbl.add colors "light sky blue" (rgb8 135 206 250)
let _ = Hashtbl.add colors "LightSkyBlue" (rgb8 135 206 250)
let _ = Hashtbl.add colors "steel blue" (rgb8 70 130 180)
let _ = Hashtbl.add colors "SteelBlue" (rgb8 70 130 180)
let _ = Hashtbl.add colors "light steel blue" (rgb8 176 196 222)
let _ = Hashtbl.add colors "LightSteelBlue" (rgb8 176 196 222)
let _ = Hashtbl.add colors "light blue" (rgb8 173 216 230)
let _ = Hashtbl.add colors "LightBlue" (rgb8 173 216 230)
let _ = Hashtbl.add colors "powder blue" (rgb8 176 224 230)
let _ = Hashtbl.add colors "PowderBlue" (rgb8 176 224 230)
let _ = Hashtbl.add colors "pale turquoise" (rgb8 175 238 238)
let _ = Hashtbl.add colors "PaleTurquoise" (rgb8 175 238 238)
let _ = Hashtbl.add colors "dark turquoise" (rgb8 0 206 209)
let _ = Hashtbl.add colors "DarkTurquoise" (rgb8 0 206 209)
let _ = Hashtbl.add colors "medium turquoise" (rgb8 72 209 204)
let _ = Hashtbl.add colors "MediumTurquoise" (rgb8 72 209 204)
let _ = Hashtbl.add colors "turquoise" (rgb8 64 224 208)
let _ = Hashtbl.add colors "cyan" (rgb8 0 255 255)
let _ = Hashtbl.add colors "light cyan" (rgb8 224 255 255)
let _ = Hashtbl.add colors "LightCyan" (rgb8 224 255 255)
let _ = Hashtbl.add colors "cadet blue" (rgb8 95 158 160)
let _ = Hashtbl.add colors "CadetBlue" (rgb8 95 158 160)
let _ = Hashtbl.add colors "medium aquamarine" (rgb8 102 205 170)
let _ = Hashtbl.add colors "MediumAquamarine" (rgb8 102 205 170)
let _ = Hashtbl.add colors "aquamarine" (rgb8 127 255 212)
let _ = Hashtbl.add colors "dark green" (rgb8 0 100 0)
let _ = Hashtbl.add colors "DarkGreen" (rgb8 0 100 0)
let _ = Hashtbl.add colors "dark olive green" (rgb8 85 107 47)
let _ = Hashtbl.add colors "DarkOliveGreen" (rgb8 85 107 47)
let _ = Hashtbl.add colors "dark sea green" (rgb8 143 188 143)
let _ = Hashtbl.add colors "DarkSeaGreen" (rgb8 143 188 143)
let _ = Hashtbl.add colors "sea green" (rgb8 46 139 87)
let _ = Hashtbl.add colors "SeaGreen" (rgb8 46 139 87)
let _ = Hashtbl.add colors "medium sea green" (rgb8 60 179 113)
let _ = Hashtbl.add colors "MediumSeaGreen" (rgb8 60 179 113)
let _ = Hashtbl.add colors "light sea green" (rgb8 32 178 170)
let _ = Hashtbl.add colors "LightSeaGreen" (rgb8 32 178 170)
let _ = Hashtbl.add colors "pale green" (rgb8 152 251 152)
let _ = Hashtbl.add colors "PaleGreen" (rgb8 152 251 152)
let _ = Hashtbl.add colors "spring green" (rgb8 0 255 127)
let _ = Hashtbl.add colors "SpringGreen" (rgb8 0 255 127)
let _ = Hashtbl.add colors "lawn green" (rgb8 124 252 0)
let _ = Hashtbl.add colors "LawnGreen" (rgb8 124 252 0)
let _ = Hashtbl.add colors "green" (rgb8 0 255 0)
let _ = Hashtbl.add colors "chartreuse" (rgb8 127 255 0)
let _ = Hashtbl.add colors "medium spring green" (rgb8 0 250 154)
let _ = Hashtbl.add colors "MediumSpringGreen" (rgb8 0 250 154)
let _ = Hashtbl.add colors "green yellow" (rgb8 173 255 47)
let _ = Hashtbl.add colors "GreenYellow" (rgb8 173 255 47)
let _ = Hashtbl.add colors "lime green" (rgb8 50 205 50)
let _ = Hashtbl.add colors "LimeGreen" (rgb8 50 205 50)
let _ = Hashtbl.add colors "yellow green" (rgb8 154 205 50)
let _ = Hashtbl.add colors "YellowGreen" (rgb8 154 205 50)
let _ = Hashtbl.add colors "forest green" (rgb8 34 139 34)
let _ = Hashtbl.add colors "ForestGreen" (rgb8 34 139 34)
let _ = Hashtbl.add colors "olive drab" (rgb8 107 142 35)
let _ = Hashtbl.add colors "OliveDrab" (rgb8 107 142 35)
let _ = Hashtbl.add colors "dark khaki" (rgb8 189 183 107)
let _ = Hashtbl.add colors "DarkKhaki" (rgb8 189 183 107)
let _ = Hashtbl.add colors "khaki" (rgb8 240 230 140)
let _ = Hashtbl.add colors "pale goldenrod" (rgb8 238 232 170)
let _ = Hashtbl.add colors "PaleGoldenrod" (rgb8 238 232 170)
let _ = Hashtbl.add colors "light goldenrod yellow" (rgb8 250 250 210)
let _ = Hashtbl.add colors "LightGoldenrodYellow" (rgb8 250 250 210)
let _ = Hashtbl.add colors "light yellow" (rgb8 255 255 224)
let _ = Hashtbl.add colors "LightYellow" (rgb8 255 255 224)
let _ = Hashtbl.add colors "yellow" (rgb8 255 255 0)
let _ = Hashtbl.add colors "gold" (rgb8 255 215 0)
let _ = Hashtbl.add colors "light goldenrod" (rgb8 238 221 130)
let _ = Hashtbl.add colors "LightGoldenrod" (rgb8 238 221 130)
let _ = Hashtbl.add colors "goldenrod" (rgb8 218 165 32)
let _ = Hashtbl.add colors "dark goldenrod" (rgb8 184 134 11)
let _ = Hashtbl.add colors "DarkGoldenrod" (rgb8 184 134 11)
let _ = Hashtbl.add colors "rosy brown" (rgb8 188 143 143)
let _ = Hashtbl.add colors "RosyBrown" (rgb8 188 143 143)
let _ = Hashtbl.add colors "indian red" (rgb8 205 92 92)
let _ = Hashtbl.add colors "IndianRed" (rgb8 205 92 92)
let _ = Hashtbl.add colors "saddle brown" (rgb8 139 69 19)
let _ = Hashtbl.add colors "SaddleBrown" (rgb8 139 69 19)
let _ = Hashtbl.add colors "sienna" (rgb8 160 82 45)
let _ = Hashtbl.add colors "peru" (rgb8 205 133 63)
let _ = Hashtbl.add colors "burlywood" (rgb8 222 184 135)
let _ = Hashtbl.add colors "beige" (rgb8 245 245 220)
let _ = Hashtbl.add colors "wheat" (rgb8 245 222 179)
let _ = Hashtbl.add colors "sandy brown" (rgb8 244 164 96)
let _ = Hashtbl.add colors "SandyBrown" (rgb8 244 164 96)
let _ = Hashtbl.add colors "tan" (rgb8 210 180 140)
let _ = Hashtbl.add colors "chocolate" (rgb8 210 105 30)
let _ = Hashtbl.add colors "firebrick" (rgb8 178 34 34)
let _ = Hashtbl.add colors "brown" (rgb8 165 42 42)
let _ = Hashtbl.add colors "dark salmon" (rgb8 233 150 122)
let _ = Hashtbl.add colors "DarkSalmon" (rgb8 233 150 122)
let _ = Hashtbl.add colors "salmon" (rgb8 250 128 114)
let _ = Hashtbl.add colors "light salmon" (rgb8 255 160 122)
let _ = Hashtbl.add colors "LightSalmon" (rgb8 255 160 122)
let _ = Hashtbl.add colors "orange" (rgb8 255 165 0)
let _ = Hashtbl.add colors "dark orange" (rgb8 255 140 0)
let _ = Hashtbl.add colors "DarkOrange" (rgb8 255 140 0)
let _ = Hashtbl.add colors "coral" (rgb8 255 127 80)
let _ = Hashtbl.add colors "light coral" (rgb8 240 128 128)
let _ = Hashtbl.add colors "LightCoral" (rgb8 240 128 128)
let _ = Hashtbl.add colors "tomato" (rgb8 255 99 71)
let _ = Hashtbl.add colors "orange red" (rgb8 255 69 0)
let _ = Hashtbl.add colors "OrangeRed" (rgb8 255 69 0)
let _ = Hashtbl.add colors "red" (rgb8 255 0 0)
let _ = Hashtbl.add colors "hot pink" (rgb8 255 105 180)
let _ = Hashtbl.add colors "HotPink" (rgb8 255 105 180)
let _ = Hashtbl.add colors "deep pink" (rgb8 255 20 147)
let _ = Hashtbl.add colors "DeepPink" (rgb8 255 20 147)
let _ = Hashtbl.add colors "pink" (rgb8 255 192 203)
let _ = Hashtbl.add colors "light pink" (rgb8 255 182 193)
let _ = Hashtbl.add colors "LightPink" (rgb8 255 182 193)
let _ = Hashtbl.add colors "pale violet red" (rgb8 219 112 147)
let _ = Hashtbl.add colors "PaleVioletRed" (rgb8 219 112 147)
let _ = Hashtbl.add colors "maroon" (rgb8 176 48 96)
let _ = Hashtbl.add colors "medium violet red" (rgb8 199 21 133)
let _ = Hashtbl.add colors "MediumVioletRed" (rgb8 199 21 133)
let _ = Hashtbl.add colors "violet red" (rgb8 208 32 144)
let _ = Hashtbl.add colors "VioletRed" (rgb8 208 32 144)
let _ = Hashtbl.add colors "magenta" (rgb8 255 0 255)
let _ = Hashtbl.add colors "violet" (rgb8 238 130 238)
let _ = Hashtbl.add colors "plum" (rgb8 221 160 221)
let _ = Hashtbl.add colors "orchid" (rgb8 218 112 214)
let _ = Hashtbl.add colors "medium orchid" (rgb8 186 85 211)
let _ = Hashtbl.add colors "MediumOrchid" (rgb8 186 85 211)
let _ = Hashtbl.add colors "dark orchid" (rgb8 153 50 204)
let _ = Hashtbl.add colors "DarkOrchid" (rgb8 153 50 204)
let _ = Hashtbl.add colors "dark violet" (rgb8 148 0 211)
let _ = Hashtbl.add colors "DarkViolet" (rgb8 148 0 211)
let _ = Hashtbl.add colors "blue violet" (rgb8 138 43 226)
let _ = Hashtbl.add colors "BlueViolet" (rgb8 138 43 226)
let _ = Hashtbl.add colors "purple" (rgb8 160 32 240)
let _ = Hashtbl.add colors "medium purple" (rgb8 147 112 219)
let _ = Hashtbl.add colors "MediumPurple" (rgb8 147 112 219)
let _ = Hashtbl.add colors "thistle" (rgb8 216 191 216)
let _ = Hashtbl.add colors "snow1" (rgb8 255 250 250)
let _ = Hashtbl.add colors "snow2" (rgb8 238 233 233)
let _ = Hashtbl.add colors "snow3" (rgb8 205 201 201)
let _ = Hashtbl.add colors "snow4" (rgb8 139 137 137)
let _ = Hashtbl.add colors "seashell1" (rgb8 255 245 238)
let _ = Hashtbl.add colors "seashell2" (rgb8 238 229 222)
let _ = Hashtbl.add colors "seashell3" (rgb8 205 197 191)
let _ = Hashtbl.add colors "seashell4" (rgb8 139 134 130)
let _ = Hashtbl.add colors "AntiqueWhite1" (rgb8 255 239 219)
let _ = Hashtbl.add colors "AntiqueWhite2" (rgb8 238 223 204)
let _ = Hashtbl.add colors "AntiqueWhite3" (rgb8 205 192 176)
let _ = Hashtbl.add colors "AntiqueWhite4" (rgb8 139 131 120)
let _ = Hashtbl.add colors "bisque1" (rgb8 255 228 196)
let _ = Hashtbl.add colors "bisque2" (rgb8 238 213 183)
let _ = Hashtbl.add colors "bisque3" (rgb8 205 183 158)
let _ = Hashtbl.add colors "bisque4" (rgb8 139 125 107)
let _ = Hashtbl.add colors "PeachPuff1" (rgb8 255 218 185)
let _ = Hashtbl.add colors "PeachPuff2" (rgb8 238 203 173)
let _ = Hashtbl.add colors "PeachPuff3" (rgb8 205 175 149)
let _ = Hashtbl.add colors "PeachPuff4" (rgb8 139 119 101)
let _ = Hashtbl.add colors "NavajoWhite1" (rgb8 255 222 173)
let _ = Hashtbl.add colors "NavajoWhite2" (rgb8 238 207 161)
let _ = Hashtbl.add colors "NavajoWhite3" (rgb8 205 179 139)
let _ = Hashtbl.add colors "NavajoWhite4" (rgb8 139 121 94)
let _ = Hashtbl.add colors "LemonChiffon1" (rgb8 255 250 205)
let _ = Hashtbl.add colors "LemonChiffon2" (rgb8 238 233 191)
let _ = Hashtbl.add colors "LemonChiffon3" (rgb8 205 201 165)
let _ = Hashtbl.add colors "LemonChiffon4" (rgb8 139 137 112)
let _ = Hashtbl.add colors "cornsilk1" (rgb8 255 248 220)
let _ = Hashtbl.add colors "cornsilk2" (rgb8 238 232 205)
let _ = Hashtbl.add colors "cornsilk3" (rgb8 205 200 177)
let _ = Hashtbl.add colors "cornsilk4" (rgb8 139 136 120)
let _ = Hashtbl.add colors "ivory1" (rgb8 255 255 240)
let _ = Hashtbl.add colors "ivory2" (rgb8 238 238 224)
let _ = Hashtbl.add colors "ivory3" (rgb8 205 205 193)
let _ = Hashtbl.add colors "ivory4" (rgb8 139 139 131)
let _ = Hashtbl.add colors "honeydew1" (rgb8 240 255 240)
let _ = Hashtbl.add colors "honeydew2" (rgb8 224 238 224)
let _ = Hashtbl.add colors "honeydew3" (rgb8 193 205 193)
let _ = Hashtbl.add colors "honeydew4" (rgb8 131 139 131)
let _ = Hashtbl.add colors "LavenderBlush1" (rgb8 255 240 245)
let _ = Hashtbl.add colors "LavenderBlush2" (rgb8 238 224 229)
let _ = Hashtbl.add colors "LavenderBlush3" (rgb8 205 193 197)
let _ = Hashtbl.add colors "LavenderBlush4" (rgb8 139 131 134)
let _ = Hashtbl.add colors "MistyRose1" (rgb8 255 228 225)
let _ = Hashtbl.add colors "MistyRose2" (rgb8 238 213 210)
let _ = Hashtbl.add colors "MistyRose3" (rgb8 205 183 181)
let _ = Hashtbl.add colors "MistyRose4" (rgb8 139 125 123)
let _ = Hashtbl.add colors "azure1" (rgb8 240 255 255)
let _ = Hashtbl.add colors "azure2" (rgb8 224 238 238)
let _ = Hashtbl.add colors "azure3" (rgb8 193 205 205)
let _ = Hashtbl.add colors "azure4" (rgb8 131 139 139)
let _ = Hashtbl.add colors "SlateBlue1" (rgb8 131 111 255)
let _ = Hashtbl.add colors "SlateBlue2" (rgb8 122 103 238)
let _ = Hashtbl.add colors "SlateBlue3" (rgb8 105 89 205)
let _ = Hashtbl.add colors "SlateBlue4" (rgb8 71 60 139)
let _ = Hashtbl.add colors "RoyalBlue1" (rgb8 72 118 255)
let _ = Hashtbl.add colors "RoyalBlue2" (rgb8 67 110 238)
let _ = Hashtbl.add colors "RoyalBlue3" (rgb8 58 95 205)
let _ = Hashtbl.add colors "RoyalBlue4" (rgb8 39 64 139)
let _ = Hashtbl.add colors "blue1" (rgb8 0 0 255)
let _ = Hashtbl.add colors "blue2" (rgb8 0 0 238)
let _ = Hashtbl.add colors "blue3" (rgb8 0 0 205)
let _ = Hashtbl.add colors "blue4" (rgb8 0 0 139)
let _ = Hashtbl.add colors "DodgerBlue1" (rgb8 30 144 255)
let _ = Hashtbl.add colors "DodgerBlue2" (rgb8 28 134 238)
let _ = Hashtbl.add colors "DodgerBlue3" (rgb8 24 116 205)
let _ = Hashtbl.add colors "DodgerBlue4" (rgb8 16 78 139)
let _ = Hashtbl.add colors "SteelBlue1" (rgb8 99 184 255)
let _ = Hashtbl.add colors "SteelBlue2" (rgb8 92 172 238)
let _ = Hashtbl.add colors "SteelBlue3" (rgb8 79 148 205)
let _ = Hashtbl.add colors "SteelBlue4" (rgb8 54 100 139)
let _ = Hashtbl.add colors "DeepSkyBlue1" (rgb8 0 191 255)
let _ = Hashtbl.add colors "DeepSkyBlue2" (rgb8 0 178 238)
let _ = Hashtbl.add colors "DeepSkyBlue3" (rgb8 0 154 205)
let _ = Hashtbl.add colors "DeepSkyBlue4" (rgb8 0 104 139)
let _ = Hashtbl.add colors "SkyBlue1" (rgb8 135 206 255)
let _ = Hashtbl.add colors "SkyBlue2" (rgb8 126 192 238)
let _ = Hashtbl.add colors "SkyBlue3" (rgb8 108 166 205)
let _ = Hashtbl.add colors "SkyBlue4" (rgb8 74 112 139)
let _ = Hashtbl.add colors "LightSkyBlue1" (rgb8 176 226 255)
let _ = Hashtbl.add colors "LightSkyBlue2" (rgb8 164 211 238)
let _ = Hashtbl.add colors "LightSkyBlue3" (rgb8 141 182 205)
let _ = Hashtbl.add colors "LightSkyBlue4" (rgb8 96 123 139)
let _ = Hashtbl.add colors "SlateGray1" (rgb8 198 226 255)
let _ = Hashtbl.add colors "SlateGray2" (rgb8 185 211 238)
let _ = Hashtbl.add colors "SlateGray3" (rgb8 159 182 205)
let _ = Hashtbl.add colors "SlateGray4" (rgb8 108 123 139)
let _ = Hashtbl.add colors "LightSteelBlue1" (rgb8 202 225 255)
let _ = Hashtbl.add colors "LightSteelBlue2" (rgb8 188 210 238)
let _ = Hashtbl.add colors "LightSteelBlue3" (rgb8 162 181 205)
let _ = Hashtbl.add colors "LightSteelBlue4" (rgb8 110 123 139)
let _ = Hashtbl.add colors "LightBlue1" (rgb8 191 239 255)
let _ = Hashtbl.add colors "LightBlue2" (rgb8 178 223 238)
let _ = Hashtbl.add colors "LightBlue3" (rgb8 154 192 205)
let _ = Hashtbl.add colors "LightBlue4" (rgb8 104 131 139)
let _ = Hashtbl.add colors "LightCyan1" (rgb8 224 255 255)
let _ = Hashtbl.add colors "LightCyan2" (rgb8 209 238 238)
let _ = Hashtbl.add colors "LightCyan3" (rgb8 180 205 205)
let _ = Hashtbl.add colors "LightCyan4" (rgb8 122 139 139)
let _ = Hashtbl.add colors "PaleTurquoise1" (rgb8 187 255 255)
let _ = Hashtbl.add colors "PaleTurquoise2" (rgb8 174 238 238)
let _ = Hashtbl.add colors "PaleTurquoise3" (rgb8 150 205 205)
let _ = Hashtbl.add colors "PaleTurquoise4" (rgb8 102 139 139)
let _ = Hashtbl.add colors "CadetBlue1" (rgb8 152 245 255)
let _ = Hashtbl.add colors "CadetBlue2" (rgb8 142 229 238)
let _ = Hashtbl.add colors "CadetBlue3" (rgb8 122 197 205)
let _ = Hashtbl.add colors "CadetBlue4" (rgb8 83 134 139)
let _ = Hashtbl.add colors "turquoise1" (rgb8 0 245 255)
let _ = Hashtbl.add colors "turquoise2" (rgb8 0 229 238)
let _ = Hashtbl.add colors "turquoise3" (rgb8 0 197 205)
let _ = Hashtbl.add colors "turquoise4" (rgb8 0 134 139)
let _ = Hashtbl.add colors "cyan1" (rgb8 0 255 255)
let _ = Hashtbl.add colors "cyan2" (rgb8 0 238 238)
let _ = Hashtbl.add colors "cyan3" (rgb8 0 205 205)
let _ = Hashtbl.add colors "cyan4" (rgb8 0 139 139)
let _ = Hashtbl.add colors "DarkSlateGray1" (rgb8 151 255 255)
let _ = Hashtbl.add colors "DarkSlateGray2" (rgb8 141 238 238)
let _ = Hashtbl.add colors "DarkSlateGray3" (rgb8 121 205 205)
let _ = Hashtbl.add colors "DarkSlateGray4" (rgb8 82 139 139)
let _ = Hashtbl.add colors "aquamarine1" (rgb8 127 255 212)
let _ = Hashtbl.add colors "aquamarine2" (rgb8 118 238 198)
let _ = Hashtbl.add colors "aquamarine3" (rgb8 102 205 170)
let _ = Hashtbl.add colors "aquamarine4" (rgb8 69 139 116)
let _ = Hashtbl.add colors "DarkSeaGreen1" (rgb8 193 255 193)
let _ = Hashtbl.add colors "DarkSeaGreen2" (rgb8 180 238 180)
let _ = Hashtbl.add colors "DarkSeaGreen3" (rgb8 155 205 155)
let _ = Hashtbl.add colors "DarkSeaGreen4" (rgb8 105 139 105)
let _ = Hashtbl.add colors "SeaGreen1" (rgb8 84 255 159)
let _ = Hashtbl.add colors "SeaGreen2" (rgb8 78 238 148)
let _ = Hashtbl.add colors "SeaGreen3" (rgb8 67 205 128)
let _ = Hashtbl.add colors "SeaGreen4" (rgb8 46 139 87)
let _ = Hashtbl.add colors "PaleGreen1" (rgb8 154 255 154)
let _ = Hashtbl.add colors "PaleGreen2" (rgb8 144 238 144)
let _ = Hashtbl.add colors "PaleGreen3" (rgb8 124 205 124)
let _ = Hashtbl.add colors "PaleGreen4" (rgb8 84 139 84)
let _ = Hashtbl.add colors "SpringGreen1" (rgb8 0 255 127)
let _ = Hashtbl.add colors "SpringGreen2" (rgb8 0 238 118)
let _ = Hashtbl.add colors "SpringGreen3" (rgb8 0 205 102)
let _ = Hashtbl.add colors "SpringGreen4" (rgb8 0 139 69)
let _ = Hashtbl.add colors "green1" (rgb8 0 255 0)
let _ = Hashtbl.add colors "green2" (rgb8 0 238 0)
let _ = Hashtbl.add colors "green3" (rgb8 0 205 0)
let _ = Hashtbl.add colors "green4" (rgb8 0 139 0)
let _ = Hashtbl.add colors "chartreuse1" (rgb8 127 255 0)
let _ = Hashtbl.add colors "chartreuse2" (rgb8 118 238 0)
let _ = Hashtbl.add colors "chartreuse3" (rgb8 102 205 0)
let _ = Hashtbl.add colors "chartreuse4" (rgb8 69 139 0)
let _ = Hashtbl.add colors "OliveDrab1" (rgb8 192 255 62)
let _ = Hashtbl.add colors "OliveDrab2" (rgb8 179 238 58)
let _ = Hashtbl.add colors "OliveDrab3" (rgb8 154 205 50)
let _ = Hashtbl.add colors "OliveDrab4" (rgb8 105 139 34)
let _ = Hashtbl.add colors "DarkOliveGreen1" (rgb8 202 255 112)
let _ = Hashtbl.add colors "DarkOliveGreen2" (rgb8 188 238 104)
let _ = Hashtbl.add colors "DarkOliveGreen3" (rgb8 162 205 90)
let _ = Hashtbl.add colors "DarkOliveGreen4" (rgb8 110 139 61)
let _ = Hashtbl.add colors "khaki1" (rgb8 255 246 143)
let _ = Hashtbl.add colors "khaki2" (rgb8 238 230 133)
let _ = Hashtbl.add colors "khaki3" (rgb8 205 198 115)
let _ = Hashtbl.add colors "khaki4" (rgb8 139 134 78)
let _ = Hashtbl.add colors "LightGoldenrod1" (rgb8 255 236 139)
let _ = Hashtbl.add colors "LightGoldenrod2" (rgb8 238 220 130)
let _ = Hashtbl.add colors "LightGoldenrod3" (rgb8 205 190 112)
let _ = Hashtbl.add colors "LightGoldenrod4" (rgb8 139 129 76)
let _ = Hashtbl.add colors "LightYellow1" (rgb8 255 255 224)
let _ = Hashtbl.add colors "LightYellow2" (rgb8 238 238 209)
let _ = Hashtbl.add colors "LightYellow3" (rgb8 205 205 180)
let _ = Hashtbl.add colors "LightYellow4" (rgb8 139 139 122)
let _ = Hashtbl.add colors "yellow1" (rgb8 255 255 0)
let _ = Hashtbl.add colors "yellow2" (rgb8 238 238 0)
let _ = Hashtbl.add colors "yellow3" (rgb8 205 205 0)
let _ = Hashtbl.add colors "yellow4" (rgb8 139 139 0)
let _ = Hashtbl.add colors "gold1" (rgb8 255 215 0)
let _ = Hashtbl.add colors "gold2" (rgb8 238 201 0)
let _ = Hashtbl.add colors "gold3" (rgb8 205 173 0)
let _ = Hashtbl.add colors "gold4" (rgb8 139 117 0)
let _ = Hashtbl.add colors "goldenrod1" (rgb8 255 193 37)
let _ = Hashtbl.add colors "goldenrod2" (rgb8 238 180 34)
let _ = Hashtbl.add colors "goldenrod3" (rgb8 205 155 29)
let _ = Hashtbl.add colors "goldenrod4" (rgb8 139 105 20)
let _ = Hashtbl.add colors "DarkGoldenrod1" (rgb8 255 185 15)
let _ = Hashtbl.add colors "DarkGoldenrod2" (rgb8 238 173 14)
let _ = Hashtbl.add colors "DarkGoldenrod3" (rgb8 205 149 12)
let _ = Hashtbl.add colors "DarkGoldenrod4" (rgb8 139 101 8)
let _ = Hashtbl.add colors "RosyBrown1" (rgb8 255 193 193)
let _ = Hashtbl.add colors "RosyBrown2" (rgb8 238 180 180)
let _ = Hashtbl.add colors "RosyBrown3" (rgb8 205 155 155)
let _ = Hashtbl.add colors "RosyBrown4" (rgb8 139 105 105)
let _ = Hashtbl.add colors "IndianRed1" (rgb8 255 106 106)
let _ = Hashtbl.add colors "IndianRed2" (rgb8 238 99 99)
let _ = Hashtbl.add colors "IndianRed3" (rgb8 205 85 85)
let _ = Hashtbl.add colors "IndianRed4" (rgb8 139 58 58)
let _ = Hashtbl.add colors "sienna1" (rgb8 255 130 71)
let _ = Hashtbl.add colors "sienna2" (rgb8 238 121 66)
let _ = Hashtbl.add colors "sienna3" (rgb8 205 104 57)
let _ = Hashtbl.add colors "sienna4" (rgb8 139 71 38)
let _ = Hashtbl.add colors "burlywood1" (rgb8 255 211 155)
let _ = Hashtbl.add colors "burlywood2" (rgb8 238 197 145)
let _ = Hashtbl.add colors "burlywood3" (rgb8 205 170 125)
let _ = Hashtbl.add colors "burlywood4" (rgb8 139 115 85)
let _ = Hashtbl.add colors "wheat1" (rgb8 255 231 186)
let _ = Hashtbl.add colors "wheat2" (rgb8 238 216 174)
let _ = Hashtbl.add colors "wheat3" (rgb8 205 186 150)
let _ = Hashtbl.add colors "wheat4" (rgb8 139 126 102)
let _ = Hashtbl.add colors "tan1" (rgb8 255 165 79)
let _ = Hashtbl.add colors "tan2" (rgb8 238 154 73)
let _ = Hashtbl.add colors "tan3" (rgb8 205 133 63)
let _ = Hashtbl.add colors "tan4" (rgb8 139 90 43)
let _ = Hashtbl.add colors "chocolate1" (rgb8 255 127 36)
let _ = Hashtbl.add colors "chocolate2" (rgb8 238 118 33)
let _ = Hashtbl.add colors "chocolate3" (rgb8 205 102 29)
let _ = Hashtbl.add colors "chocolate4" (rgb8 139 69 19)
let _ = Hashtbl.add colors "firebrick1" (rgb8 255 48 48)
let _ = Hashtbl.add colors "firebrick2" (rgb8 238 44 44)
let _ = Hashtbl.add colors "firebrick3" (rgb8 205 38 38)
let _ = Hashtbl.add colors "firebrick4" (rgb8 139 26 26)
let _ = Hashtbl.add colors "brown1" (rgb8 255 64 64)
let _ = Hashtbl.add colors "brown2" (rgb8 238 59 59)
let _ = Hashtbl.add colors "brown3" (rgb8 205 51 51)
let _ = Hashtbl.add colors "brown4" (rgb8 139 35 35)
let _ = Hashtbl.add colors "salmon1" (rgb8 255 140 105)
let _ = Hashtbl.add colors "salmon2" (rgb8 238 130 98)
let _ = Hashtbl.add colors "salmon3" (rgb8 205 112 84)
let _ = Hashtbl.add colors "salmon4" (rgb8 139 76 57)
let _ = Hashtbl.add colors "LightSalmon1" (rgb8 255 160 122)
let _ = Hashtbl.add colors "LightSalmon2" (rgb8 238 149 114)
let _ = Hashtbl.add colors "LightSalmon3" (rgb8 205 129 98)
let _ = Hashtbl.add colors "LightSalmon4" (rgb8 139 87 66)
let _ = Hashtbl.add colors "orange1" (rgb8 255 165 0)
let _ = Hashtbl.add colors "orange2" (rgb8 238 154 0)
let _ = Hashtbl.add colors "orange3" (rgb8 205 133 0)
let _ = Hashtbl.add colors "orange4" (rgb8 139 90 0)
let _ = Hashtbl.add colors "DarkOrange1" (rgb8 255 127 0)
let _ = Hashtbl.add colors "DarkOrange2" (rgb8 238 118 0)
let _ = Hashtbl.add colors "DarkOrange3" (rgb8 205 102 0)
let _ = Hashtbl.add colors "DarkOrange4" (rgb8 139 69 0)
let _ = Hashtbl.add colors "coral1" (rgb8 255 114 86)
let _ = Hashtbl.add colors "coral2" (rgb8 238 106 80)
let _ = Hashtbl.add colors "coral3" (rgb8 205 91 69)
let _ = Hashtbl.add colors "coral4" (rgb8 139 62 47)
let _ = Hashtbl.add colors "tomato1" (rgb8 255 99 71)
let _ = Hashtbl.add colors "tomato2" (rgb8 238 92 66)
let _ = Hashtbl.add colors "tomato3" (rgb8 205 79 57)
let _ = Hashtbl.add colors "tomato4" (rgb8 139 54 38)
let _ = Hashtbl.add colors "OrangeRed1" (rgb8 255 69 0)
let _ = Hashtbl.add colors "OrangeRed2" (rgb8 238 64 0)
let _ = Hashtbl.add colors "OrangeRed3" (rgb8 205 55 0)
let _ = Hashtbl.add colors "OrangeRed4" (rgb8 139 37 0)
let _ = Hashtbl.add colors "red1" (rgb8 255 0 0)
let _ = Hashtbl.add colors "red2" (rgb8 238 0 0)
let _ = Hashtbl.add colors "red3" (rgb8 205 0 0)
let _ = Hashtbl.add colors "red4" (rgb8 139 0 0)
let _ = Hashtbl.add colors "DebianRed" (rgb8 215 7 81)
let _ = Hashtbl.add colors "DeepPink1" (rgb8 255 20 147)
let _ = Hashtbl.add colors "DeepPink2" (rgb8 238 18 137)
let _ = Hashtbl.add colors "DeepPink3" (rgb8 205 16 118)
let _ = Hashtbl.add colors "DeepPink4" (rgb8 139 10 80)
let _ = Hashtbl.add colors "HotPink1" (rgb8 255 110 180)
let _ = Hashtbl.add colors "HotPink2" (rgb8 238 106 167)
let _ = Hashtbl.add colors "HotPink3" (rgb8 205 96 144)
let _ = Hashtbl.add colors "HotPink4" (rgb8 139 58 98)
let _ = Hashtbl.add colors "pink1" (rgb8 255 181 197)
let _ = Hashtbl.add colors "pink2" (rgb8 238 169 184)
let _ = Hashtbl.add colors "pink3" (rgb8 205 145 158)
let _ = Hashtbl.add colors "pink4" (rgb8 139 99 108)
let _ = Hashtbl.add colors "LightPink1" (rgb8 255 174 185)
let _ = Hashtbl.add colors "LightPink2" (rgb8 238 162 173)
let _ = Hashtbl.add colors "LightPink3" (rgb8 205 140 149)
let _ = Hashtbl.add colors "LightPink4" (rgb8 139 95 101)
let _ = Hashtbl.add colors "PaleVioletRed1" (rgb8 255 130 171)
let _ = Hashtbl.add colors "PaleVioletRed2" (rgb8 238 121 159)
let _ = Hashtbl.add colors "PaleVioletRed3" (rgb8 205 104 137)
let _ = Hashtbl.add colors "PaleVioletRed4" (rgb8 139 71 93)
let _ = Hashtbl.add colors "maroon1" (rgb8 255 52 179)
let _ = Hashtbl.add colors "maroon2" (rgb8 238 48 167)
let _ = Hashtbl.add colors "maroon3" (rgb8 205 41 144)
let _ = Hashtbl.add colors "maroon4" (rgb8 139 28 98)
let _ = Hashtbl.add colors "VioletRed1" (rgb8 255 62 150)
let _ = Hashtbl.add colors "VioletRed2" (rgb8 238 58 140)
let _ = Hashtbl.add colors "VioletRed3" (rgb8 205 50 120)
let _ = Hashtbl.add colors "VioletRed4" (rgb8 139 34 82)
let _ = Hashtbl.add colors "magenta1" (rgb8 255 0 255)
let _ = Hashtbl.add colors "magenta2" (rgb8 238 0 238)
let _ = Hashtbl.add colors "magenta3" (rgb8 205 0 205)
let _ = Hashtbl.add colors "magenta4" (rgb8 139 0 139)
let _ = Hashtbl.add colors "orchid1" (rgb8 255 131 250)
let _ = Hashtbl.add colors "orchid2" (rgb8 238 122 233)
let _ = Hashtbl.add colors "orchid3" (rgb8 205 105 201)
let _ = Hashtbl.add colors "orchid4" (rgb8 139 71 137)
let _ = Hashtbl.add colors "plum1" (rgb8 255 187 255)
let _ = Hashtbl.add colors "plum2" (rgb8 238 174 238)
let _ = Hashtbl.add colors "plum3" (rgb8 205 150 205)
let _ = Hashtbl.add colors "plum4" (rgb8 139 102 139)
let _ = Hashtbl.add colors "MediumOrchid1" (rgb8 224 102 255)
let _ = Hashtbl.add colors "MediumOrchid2" (rgb8 209 95 238)
let _ = Hashtbl.add colors "MediumOrchid3" (rgb8 180 82 205)
let _ = Hashtbl.add colors "MediumOrchid4" (rgb8 122 55 139)
let _ = Hashtbl.add colors "DarkOrchid1" (rgb8 191 62 255)
let _ = Hashtbl.add colors "DarkOrchid2" (rgb8 178 58 238)
let _ = Hashtbl.add colors "DarkOrchid3" (rgb8 154 50 205)
let _ = Hashtbl.add colors "DarkOrchid4" (rgb8 104 34 139)
let _ = Hashtbl.add colors "purple1" (rgb8 155 48 255)
let _ = Hashtbl.add colors "purple2" (rgb8 145 44 238)
let _ = Hashtbl.add colors "purple3" (rgb8 125 38 205)
let _ = Hashtbl.add colors "purple4" (rgb8 85 26 139)
let _ = Hashtbl.add colors "MediumPurple1" (rgb8 171 130 255)
let _ = Hashtbl.add colors "MediumPurple2" (rgb8 159 121 238)
let _ = Hashtbl.add colors "MediumPurple3" (rgb8 137 104 205)
let _ = Hashtbl.add colors "MediumPurple4" (rgb8 93 71 139)
let _ = Hashtbl.add colors "thistle1" (rgb8 255 225 255)
let _ = Hashtbl.add colors "thistle2" (rgb8 238 210 238)
let _ = Hashtbl.add colors "thistle3" (rgb8 205 181 205)
let _ = Hashtbl.add colors "thistle4" (rgb8 139 123 139)
let _ = Hashtbl.add colors "gray0" (rgb8 0 0 0)
let _ = Hashtbl.add colors "grey0" (rgb8 0 0 0)
let _ = Hashtbl.add colors "gray1" (rgb8 3 3 3)
let _ = Hashtbl.add colors "grey1" (rgb8 3 3 3)
let _ = Hashtbl.add colors "gray2" (rgb8 5 5 5)
let _ = Hashtbl.add colors "grey2" (rgb8 5 5 5)
let _ = Hashtbl.add colors "gray3" (rgb8 8 8 8)
let _ = Hashtbl.add colors "grey3" (rgb8 8 8 8)
let _ = Hashtbl.add colors "gray4" (rgb8 10 10 10)
let _ = Hashtbl.add colors "grey4" (rgb8 10 10 10)
let _ = Hashtbl.add colors "gray5" (rgb8 13 13 13)
let _ = Hashtbl.add colors "grey5" (rgb8 13 13 13)
let _ = Hashtbl.add colors "gray6" (rgb8 15 15 15)
let _ = Hashtbl.add colors "grey6" (rgb8 15 15 15)
let _ = Hashtbl.add colors "gray7" (rgb8 18 18 18)
let _ = Hashtbl.add colors "grey7" (rgb8 18 18 18)
let _ = Hashtbl.add colors "gray8" (rgb8 20 20 20)
let _ = Hashtbl.add colors "grey8" (rgb8 20 20 20)
let _ = Hashtbl.add colors "gray9" (rgb8 23 23 23)
let _ = Hashtbl.add colors "grey9" (rgb8 23 23 23)
let _ = Hashtbl.add colors "gray10" (rgb8 26 26 26)
let _ = Hashtbl.add colors "grey10" (rgb8 26 26 26)
let _ = Hashtbl.add colors "gray11" (rgb8 28 28 28)
let _ = Hashtbl.add colors "grey11" (rgb8 28 28 28)
let _ = Hashtbl.add colors "gray12" (rgb8 31 31 31)
let _ = Hashtbl.add colors "grey12" (rgb8 31 31 31)
let _ = Hashtbl.add colors "gray13" (rgb8 33 33 33)
let _ = Hashtbl.add colors "grey13" (rgb8 33 33 33)
let _ = Hashtbl.add colors "gray14" (rgb8 36 36 36)
let _ = Hashtbl.add colors "grey14" (rgb8 36 36 36)
let _ = Hashtbl.add colors "gray15" (rgb8 38 38 38)
let _ = Hashtbl.add colors "grey15" (rgb8 38 38 38)
let _ = Hashtbl.add colors "gray16" (rgb8 41 41 41)
let _ = Hashtbl.add colors "grey16" (rgb8 41 41 41)
let _ = Hashtbl.add colors "gray17" (rgb8 43 43 43)
let _ = Hashtbl.add colors "grey17" (rgb8 43 43 43)
let _ = Hashtbl.add colors "gray18" (rgb8 46 46 46)
let _ = Hashtbl.add colors "grey18" (rgb8 46 46 46)
let _ = Hashtbl.add colors "gray19" (rgb8 48 48 48)
let _ = Hashtbl.add colors "grey19" (rgb8 48 48 48)
let _ = Hashtbl.add colors "gray20" (rgb8 51 51 51)
let _ = Hashtbl.add colors "grey20" (rgb8 51 51 51)
let _ = Hashtbl.add colors "gray21" (rgb8 54 54 54)
let _ = Hashtbl.add colors "grey21" (rgb8 54 54 54)
let _ = Hashtbl.add colors "gray22" (rgb8 56 56 56)
let _ = Hashtbl.add colors "grey22" (rgb8 56 56 56)
let _ = Hashtbl.add colors "gray23" (rgb8 59 59 59)
let _ = Hashtbl.add colors "grey23" (rgb8 59 59 59)
let _ = Hashtbl.add colors "gray24" (rgb8 61 61 61)
let _ = Hashtbl.add colors "grey24" (rgb8 61 61 61)
let _ = Hashtbl.add colors "gray25" (rgb8 64 64 64)
let _ = Hashtbl.add colors "grey25" (rgb8 64 64 64)
let _ = Hashtbl.add colors "gray26" (rgb8 66 66 66)
let _ = Hashtbl.add colors "grey26" (rgb8 66 66 66)
let _ = Hashtbl.add colors "gray27" (rgb8 69 69 69)
let _ = Hashtbl.add colors "grey27" (rgb8 69 69 69)
let _ = Hashtbl.add colors "gray28" (rgb8 71 71 71)
let _ = Hashtbl.add colors "grey28" (rgb8 71 71 71)
let _ = Hashtbl.add colors "gray29" (rgb8 74 74 74)
let _ = Hashtbl.add colors "grey29" (rgb8 74 74 74)
let _ = Hashtbl.add colors "gray30" (rgb8 77 77 77)
let _ = Hashtbl.add colors "grey30" (rgb8 77 77 77)
let _ = Hashtbl.add colors "gray31" (rgb8 79 79 79)
let _ = Hashtbl.add colors "grey31" (rgb8 79 79 79)
let _ = Hashtbl.add colors "gray32" (rgb8 82 82 82)
let _ = Hashtbl.add colors "grey32" (rgb8 82 82 82)
let _ = Hashtbl.add colors "gray33" (rgb8 84 84 84)
let _ = Hashtbl.add colors "grey33" (rgb8 84 84 84)
let _ = Hashtbl.add colors "gray34" (rgb8 87 87 87)
let _ = Hashtbl.add colors "grey34" (rgb8 87 87 87)
let _ = Hashtbl.add colors "gray35" (rgb8 89 89 89)
let _ = Hashtbl.add colors "grey35" (rgb8 89 89 89)
let _ = Hashtbl.add colors "gray36" (rgb8 92 92 92)
let _ = Hashtbl.add colors "grey36" (rgb8 92 92 92)
let _ = Hashtbl.add colors "gray37" (rgb8 94 94 94)
let _ = Hashtbl.add colors "grey37" (rgb8 94 94 94)
let _ = Hashtbl.add colors "gray38" (rgb8 97 97 97)
let _ = Hashtbl.add colors "grey38" (rgb8 97 97 97)
let _ = Hashtbl.add colors "gray39" (rgb8 99 99 99)
let _ = Hashtbl.add colors "grey39" (rgb8 99 99 99)
let _ = Hashtbl.add colors "gray40" (rgb8 102 102 102)
let _ = Hashtbl.add colors "grey40" (rgb8 102 102 102)
let _ = Hashtbl.add colors "gray41" (rgb8 105 105 105)
let _ = Hashtbl.add colors "grey41" (rgb8 105 105 105)
let _ = Hashtbl.add colors "gray42" (rgb8 107 107 107)
let _ = Hashtbl.add colors "grey42" (rgb8 107 107 107)
let _ = Hashtbl.add colors "gray43" (rgb8 110 110 110)
let _ = Hashtbl.add colors "grey43" (rgb8 110 110 110)
let _ = Hashtbl.add colors "gray44" (rgb8 112 112 112)
let _ = Hashtbl.add colors "grey44" (rgb8 112 112 112)
let _ = Hashtbl.add colors "gray45" (rgb8 115 115 115)
let _ = Hashtbl.add colors "grey45" (rgb8 115 115 115)
let _ = Hashtbl.add colors "gray46" (rgb8 117 117 117)
let _ = Hashtbl.add colors "grey46" (rgb8 117 117 117)
let _ = Hashtbl.add colors "gray47" (rgb8 120 120 120)
let _ = Hashtbl.add colors "grey47" (rgb8 120 120 120)
let _ = Hashtbl.add colors "gray48" (rgb8 122 122 122)
let _ = Hashtbl.add colors "grey48" (rgb8 122 122 122)
let _ = Hashtbl.add colors "gray49" (rgb8 125 125 125)
let _ = Hashtbl.add colors "grey49" (rgb8 125 125 125)
let _ = Hashtbl.add colors "gray50" (rgb8 127 127 127)
let _ = Hashtbl.add colors "grey50" (rgb8 127 127 127)
let _ = Hashtbl.add colors "gray51" (rgb8 130 130 130)
let _ = Hashtbl.add colors "grey51" (rgb8 130 130 130)
let _ = Hashtbl.add colors "gray52" (rgb8 133 133 133)
let _ = Hashtbl.add colors "grey52" (rgb8 133 133 133)
let _ = Hashtbl.add colors "gray53" (rgb8 135 135 135)
let _ = Hashtbl.add colors "grey53" (rgb8 135 135 135)
let _ = Hashtbl.add colors "gray54" (rgb8 138 138 138)
let _ = Hashtbl.add colors "grey54" (rgb8 138 138 138)
let _ = Hashtbl.add colors "gray55" (rgb8 140 140 140)
let _ = Hashtbl.add colors "grey55" (rgb8 140 140 140)
let _ = Hashtbl.add colors "gray56" (rgb8 143 143 143)
let _ = Hashtbl.add colors "grey56" (rgb8 143 143 143)
let _ = Hashtbl.add colors "gray57" (rgb8 145 145 145)
let _ = Hashtbl.add colors "grey57" (rgb8 145 145 145)
let _ = Hashtbl.add colors "gray58" (rgb8 148 148 148)
let _ = Hashtbl.add colors "grey58" (rgb8 148 148 148)
let _ = Hashtbl.add colors "gray59" (rgb8 150 150 150)
let _ = Hashtbl.add colors "grey59" (rgb8 150 150 150)
let _ = Hashtbl.add colors "gray60" (rgb8 153 153 153)
let _ = Hashtbl.add colors "grey60" (rgb8 153 153 153)
let _ = Hashtbl.add colors "gray61" (rgb8 156 156 156)
let _ = Hashtbl.add colors "grey61" (rgb8 156 156 156)
let _ = Hashtbl.add colors "gray62" (rgb8 158 158 158)
let _ = Hashtbl.add colors "grey62" (rgb8 158 158 158)
let _ = Hashtbl.add colors "gray63" (rgb8 161 161 161)
let _ = Hashtbl.add colors "grey63" (rgb8 161 161 161)
let _ = Hashtbl.add colors "gray64" (rgb8 163 163 163)
let _ = Hashtbl.add colors "grey64" (rgb8 163 163 163)
let _ = Hashtbl.add colors "gray65" (rgb8 166 166 166)
let _ = Hashtbl.add colors "grey65" (rgb8 166 166 166)
let _ = Hashtbl.add colors "gray66" (rgb8 168 168 168)
let _ = Hashtbl.add colors "grey66" (rgb8 168 168 168)
let _ = Hashtbl.add colors "gray67" (rgb8 171 171 171)
let _ = Hashtbl.add colors "grey67" (rgb8 171 171 171)
let _ = Hashtbl.add colors "gray68" (rgb8 173 173 173)
let _ = Hashtbl.add colors "grey68" (rgb8 173 173 173)
let _ = Hashtbl.add colors "gray69" (rgb8 176 176 176)
let _ = Hashtbl.add colors "grey69" (rgb8 176 176 176)
let _ = Hashtbl.add colors "gray70" (rgb8 179 179 179)
let _ = Hashtbl.add colors "grey70" (rgb8 179 179 179)
let _ = Hashtbl.add colors "gray71" (rgb8 181 181 181)
let _ = Hashtbl.add colors "grey71" (rgb8 181 181 181)
let _ = Hashtbl.add colors "gray72" (rgb8 184 184 184)
let _ = Hashtbl.add colors "grey72" (rgb8 184 184 184)
let _ = Hashtbl.add colors "gray73" (rgb8 186 186 186)
let _ = Hashtbl.add colors "grey73" (rgb8 186 186 186)
let _ = Hashtbl.add colors "gray74" (rgb8 189 189 189)
let _ = Hashtbl.add colors "grey74" (rgb8 189 189 189)
let _ = Hashtbl.add colors "gray75" (rgb8 191 191 191)
let _ = Hashtbl.add colors "grey75" (rgb8 191 191 191)
let _ = Hashtbl.add colors "gray76" (rgb8 194 194 194)
let _ = Hashtbl.add colors "grey76" (rgb8 194 194 194)
let _ = Hashtbl.add colors "gray77" (rgb8 196 196 196)
let _ = Hashtbl.add colors "grey77" (rgb8 196 196 196)
let _ = Hashtbl.add colors "gray78" (rgb8 199 199 199)
let _ = Hashtbl.add colors "grey78" (rgb8 199 199 199)
let _ = Hashtbl.add colors "gray79" (rgb8 201 201 201)
let _ = Hashtbl.add colors "grey79" (rgb8 201 201 201)
let _ = Hashtbl.add colors "gray80" (rgb8 204 204 204)
let _ = Hashtbl.add colors "grey80" (rgb8 204 204 204)
let _ = Hashtbl.add colors "gray81" (rgb8 207 207 207)
let _ = Hashtbl.add colors "grey81" (rgb8 207 207 207)
let _ = Hashtbl.add colors "gray82" (rgb8 209 209 209)
let _ = Hashtbl.add colors "grey82" (rgb8 209 209 209)
let _ = Hashtbl.add colors "gray83" (rgb8 212 212 212)
let _ = Hashtbl.add colors "grey83" (rgb8 212 212 212)
let _ = Hashtbl.add colors "gray84" (rgb8 214 214 214)
let _ = Hashtbl.add colors "grey84" (rgb8 214 214 214)
let _ = Hashtbl.add colors "gray85" (rgb8 217 217 217)
let _ = Hashtbl.add colors "grey85" (rgb8 217 217 217)
let _ = Hashtbl.add colors "gray86" (rgb8 219 219 219)
let _ = Hashtbl.add colors "grey86" (rgb8 219 219 219)
let _ = Hashtbl.add colors "gray87" (rgb8 222 222 222)
let _ = Hashtbl.add colors "grey87" (rgb8 222 222 222)
let _ = Hashtbl.add colors "gray88" (rgb8 224 224 224)
let _ = Hashtbl.add colors "grey88" (rgb8 224 224 224)
let _ = Hashtbl.add colors "gray89" (rgb8 227 227 227)
let _ = Hashtbl.add colors "grey89" (rgb8 227 227 227)
let _ = Hashtbl.add colors "gray90" (rgb8 229 229 229)
let _ = Hashtbl.add colors "grey90" (rgb8 229 229 229)
let _ = Hashtbl.add colors "gray91" (rgb8 232 232 232)
let _ = Hashtbl.add colors "grey91" (rgb8 232 232 232)
let _ = Hashtbl.add colors "gray92" (rgb8 235 235 235)
let _ = Hashtbl.add colors "grey92" (rgb8 235 235 235)
let _ = Hashtbl.add colors "gray93" (rgb8 237 237 237)
let _ = Hashtbl.add colors "grey93" (rgb8 237 237 237)
let _ = Hashtbl.add colors "gray94" (rgb8 240 240 240)
let _ = Hashtbl.add colors "grey94" (rgb8 240 240 240)
let _ = Hashtbl.add colors "gray95" (rgb8 242 242 242)
let _ = Hashtbl.add colors "grey95" (rgb8 242 242 242)
let _ = Hashtbl.add colors "gray96" (rgb8 245 245 245)
let _ = Hashtbl.add colors "grey96" (rgb8 245 245 245)
let _ = Hashtbl.add colors "gray97" (rgb8 247 247 247)
let _ = Hashtbl.add colors "grey97" (rgb8 247 247 247)
let _ = Hashtbl.add colors "gray98" (rgb8 250 250 250)
let _ = Hashtbl.add colors "grey98" (rgb8 250 250 250)
let _ = Hashtbl.add colors "gray99" (rgb8 252 252 252)
let _ = Hashtbl.add colors "grey99" (rgb8 252 252 252)
let _ = Hashtbl.add colors "gray100" (rgb8 255 255 255)
let _ = Hashtbl.add colors "grey100" (rgb8 255 255 255)
let _ = Hashtbl.add colors "dark grey" (rgb8 169 169 169)
let _ = Hashtbl.add colors "DarkGrey" (rgb8 169 169 169)
let _ = Hashtbl.add colors "dark gray" (rgb8 169 169 169)
let _ = Hashtbl.add colors "DarkGray" (rgb8 169 169 169)
let _ = Hashtbl.add colors "dark blue" (rgb8 0 0 139)
let _ = Hashtbl.add colors "DarkBlue" (rgb8 0 0 139)
let _ = Hashtbl.add colors "dark cyan" (rgb8 0 139 139)
let _ = Hashtbl.add colors "DarkCyan" (rgb8 0 139 139)
let _ = Hashtbl.add colors "dark magenta" (rgb8 139 0 139)
let _ = Hashtbl.add colors "DarkMagenta" (rgb8 139 0 139)
let _ = Hashtbl.add colors "dark red" (rgb8 139 0 0)
let _ = Hashtbl.add colors "DarkRed" (rgb8 139 0 0)
let _ = Hashtbl.add colors "light green" (rgb8 144 238 144)
let _ = Hashtbl.add colors "LightGreen" (rgb8 144 238 144)
mlpost-0.8.2/command.ml 0000664 0000000 0000000 00000004777 13060465153 0015031 0 ustar 00root root 0000000 0000000 (**************************************************************************)
(* *)
(* Copyright (C) Johannes Kanig, Stephane Lescuyer *)
(* Jean-Christophe Filliatre, Romain Bardou and Francois Bobot *)
(* *)
(* This software is free software; you can redistribute it and/or *)
(* modify it under the terms of the GNU Library General Public *)
(* License version 2.1, with the special exception on linking *)
(* described in file LICENSE. *)
(* *)
(* This software is distributed in the hope that it will be useful, *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *)
(* *)
(**************************************************************************)
open Misc
open Types
module T = Transform
type hposition = Types.hposition
type vposition = Types.vposition
type position = Types.position
type t = commandpic
let label ?(pos=`Center) pic point =
mkCommand (mkCLabel pic pos point)
(* replace later *)
let dotlabel ?(pos=`Center) pic point =
mkCommand (mkCDotLabel pic pos point)
let draw ?brush ?color ?pen ?dashed t =
(* We don't use a default to avoid the output of
... withcolor (0.00red+0.00green+0.00blue) withpen ....
for each command in the output file *)
mkCommand (mkCDraw t (mkBrushOpt brush color pen dashed))
let fill ?color t =
mkCommand (mkCFill t color)
let seq l = mkSeq l
let iter from until f =
let l = Misc.fold_from_to (fun acc i -> f i :: acc) [] from until in
seq (List.rev l)
let draw_pic p = p
let append c1 c2 = seq [c1; c2]
let (++) = append
let externalimage filename spec =
if not (Filename.check_suffix filename "png")
then invalid_arg
(Format.sprintf "externalimage support only png image : %s" filename);
if not (Sys.file_exists filename)
then invalid_arg
(Format.sprintf "externalimage file doesn't exist : %s" filename);
let filename =
if Filename.is_relative filename
then Filename.concat (Sys.getcwd ()) filename
else filename in
mkCommand (mkCExternalImage filename spec)
(* syntactic sugar *)
let iterl f l = seq (List.map f l)
let nop = seq []
mlpost-0.8.2/compile.ml 0000664 0000000 0000000 00000021205 13060465153 0015024 0 ustar 00root root 0000000 0000000 (**************************************************************************)
(* *)
(* Copyright (C) Johannes Kanig, Stephane Lescuyer *)
(* Jean-Christophe Filliatre, Romain Bardou and Francois Bobot *)
(* *)
(* This software is free software; you can redistribute it and/or *)
(* modify it under the terms of the GNU Library General Public *)
(* License version 2.1, with the special exception on linking *)
(* described in file LICENSE. *)
(* *)
(* This software is distributed in the hope that it will be useful, *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *)
(* *)
(**************************************************************************)
open Types
open Hashcons
module C = Compiled_types
module D = Duplicate
let nop = C.CSeq []
let (++) c1 c2 =
match c1,c2 with
| C.CSeq [], _ -> c2
| _, C.CSeq [] -> c1
| _, _ -> C.CSeq [c1 ; c2]
let path_names = D.PthM.create 257
let picture_names = D.PicM.create 257
let option_compile f = function
| None -> None, nop
| Some obj ->
let obj, c = f obj in
Some obj, c
let rec num n = n, nop
and point p = p, nop
and knot k =
match k.Hashcons.node with
| { knot_in = d1 ; knot_p = p ; knot_out = d2 } ->
let d1, c1 = direction d1 in
let p, c2 = point p in
let d2, c3 = direction d2 in
(d1,p,d2), c1 ++ c2 ++ c3
and joint j =
match j.Hashcons.node with
| JLine -> C.JLine, nop
| JCurve -> C.JCurve, nop
| JCurveNoInflex -> C.JCurveNoInflex, nop
| JTension (a,b) -> C.JTension (a,b), nop
| JControls (p1,p2) ->
let p1,c1 = point p1 in
let p2,c2 = point p2 in
C.JControls (p1,p2), c1 ++ c2
and direction d =
match d.Hashcons.node with
| Vec p ->
let p, code = point p in
C.Vec p, code
| Curl f -> C.Curl f, nop
| NoDir -> C.NoDir, nop
and metapath p =
match p.Hashcons.node with
| MPAConcat (pa,j,p) ->
let p, c1 = metapath p in
let pa, c2 = knot pa in
let j, c3 = joint j in
C.PAConcat (pa,j,p), c1 ++ c2 ++ c3
| MPAAppend (p1,j,p2) ->
let p1, c1 = metapath p1 in
let j, c2 = joint j in
let p2, c3 = metapath p2 in
C.PAAppend (p1,j,p2), c1 ++ c2 ++ c3
| MPAKnot path ->
let path, code = knot path in
C.PAKnot path, code
| MPAofPA p ->
let p,c = path p in
C.PAScope p, c
and path' = function
| PAofMPA p ->
let p,c = metapath p in
C.PAScope p, c
| MPACycle (d,j,p) ->
let d, c1 = direction d in
let j, c2 = joint j in
let p, c3 = metapath p in
C.PACycle (d,j,p), c1 ++ c2 ++ c3
| PATransformed (p,tr) ->
let p, c1 = path p in
let tr, c2 = transform tr in
(* group transformations, for slightly smaller metapost code *)
(* this only happens in the Metapost AST, to be able to use
* path components that already have a name *)
C.PATransformed(p,tr), c1 ++ c2
| PACutAfter (p1,p2) ->
let p1, c1 = path p1 in
let p2, c2 = path p2 in
C.PACutAfter (p1,p2), c1 ++ c2
| PACutBefore (p1,p2) ->
let p1, c1 = path p1 in
let p2, c2 = path p2 in
C.PACutBefore (p1,p2), c1 ++ c2
| PABuildCycle pl ->
let npl = List.map path pl in
C.PABuildCycle (List.map fst npl), C.CSeq (List.map snd npl)
| PASub (f1, f2, p) ->
(* the Metapost subpath command needs a path name as argument *)
let f1, c1 = num f1 in
let f2, c2 = num f2 in
let p', code = path_save p in
begin
match p' with
| C.PAName x -> C.PASub (f1,f2,x), c1 ++ c2 ++ code
| _ -> assert false
end
| PABBox p ->
let p, code = commandpic_pic p in
C.PABBox p, code
| PAUnitSquare -> C.PAUnitSquare, nop
| PAQuarterCircle -> C.PAQuarterCircle, nop
| PAHalfCircle -> C.PAHalfCircle, nop
| PAFullCircle -> C.PAFullCircle, nop
and path p =
let cnt = !(D.PthM.find D.path_map p) in
if cnt >= 2 then path_save p
else path' p.node
and path_save p =
try
let x = D.PthM.find path_names p in
C.PAName x, nop
with Not_found ->
let p', code = path' p.node in
let x = Name.path () in
let () = D.PthM.add path_names p x in
C.PAName x, code ++ C.CDeclPath (x,p')
and picture' = function
| PITransformed (p,tr) ->
let tr, c1 = transform tr in
let pic, c2 = commandpic_pic p in
C.PITransformed (pic,tr), c1 ++ c2
| PITex s -> C.PITex s, nop
| PIClip (pic,pth) ->
let pic, c1 = commandpic_pic_save pic in
let pth, c2 = path pth in
let pn = Name.picture () in
(* slight redundance here *)
C.PIName pn, c1 ++ c2 ++ C.CSimplePic (pn,pic) ++ C.CClip (pn,pth)
and picture pic =
let cnt = !(D.PicM.find D.picture_map pic) in
if cnt >= 2 then picture_save pic
else picture' pic.node
and picture_save pic =
try
let x = D.PicM.find picture_names pic in
C.PIName x, nop
with Not_found ->
let x = Name.picture () in
let () = D.PicM.add picture_names pic x in
let pic', code = picture' pic.node in
C.PIName x, code ++ C.CSimplePic (x,pic')
and commandpic_pic pc =
match pc.Hashcons.node with
| Picture p -> picture p
| Command c ->
let pn = Name.picture () in
C.PIName pn, C.CDefPic (pn, command c)
| Seq l ->
let pn = Name.picture () in
C.PIName pn, C.CDefPic (pn, C.CSeq (List.map commandpic_cmd l))
and commandpic_pic_save pc =
match pc.Hashcons.node with
| Picture p -> picture_save p
| _ -> commandpic_pic pc
and commandpic_cmd pc =
match pc.Hashcons.node with
| Picture p ->
let p, code = picture p in
C.CSeq [code; C.CDrawPic p]
| Command c -> command c
| Seq l -> C.CSeq (List.map commandpic_cmd l)
and transform t =
let t = List.fold_left Matrix.multiply Matrix.identity t in
let pn = Name.transform () in
pn, C.CDefTrans (pn, t)
and pen p =
match p.Hashcons.node with
| PenCircle -> C.PenCircle, nop
| PenSquare -> C.PenSquare, nop
| PenFromPath p ->
let p, code = path p in
C.PenFromPath p, code
| PenTransformed (p, tr) ->
let p, c1 = pen p in
let tr, c2 = transform tr in
C.PenTransformed (p,tr), c1 ++ c2
and dash d =
match d.Hashcons.node with
| DEvenly -> C.DEvenly, nop
| DWithdots -> C.DWithdots, nop
| DScaled (f, d) ->
let f,c1 = num f in
let d,c2 = dash d in
C.DScaled (f,d) , c1 ++ c2
| DShifted (p,d) ->
let p, c1 = point p in
let d, c2 = dash d in
C.DShifted (p,d), c1 ++ c2
| DPattern l ->
let l1,l2 = List.fold_right
(fun pat (patl, cl) ->
let pat,c = dash_pattern pat in
pat::patl, c::cl ) l ([],[]) in
C.DPattern l1, C.CSeq l2
and dash_pattern o =
match o.Hashcons.node with
| On f ->
let f1, c1 = num f in C.On f1, c1
| Off f ->
let f1, c1 = num f in C.Off f1, c1
and command c =
match c.Hashcons.node with
| CDraw (p, b) ->
let p, c1 = path p in
let {color = color; pen = pe; dash = dsh} = b.Hashcons.node in
let pe, c2 = (option_compile pen) pe in
let dsh, c3 = (option_compile dash) dsh in
C.CSeq [c1; c2; c3; C.CDraw (p, color, pe, dsh)]
(*
| CDrawPic p ->
let p, code = picture p in
C.CSeq [code; C.CDrawPic p]
*)
| CFill (p, c) ->
let p, code = path p in
C.CSeq [code; C.CFill (p, c)]
| CDotLabel (pic, pos, pt) ->
let pic, c1 = commandpic_pic pic in
let pt, c2 = point pt in
c1 ++ c2 ++ C.CDotLabel (pic,pos,pt)
| CLabel (pic, pos ,pt) ->
let pic, c1 = commandpic_pic pic in
let pt, c2 = point pt in
c1 ++ c2 ++ C.CLabel (pic,pos,pt)
| CExternalImage (filename,spec) ->
let spec,code = match spec with
| `Exact (h,w) ->
let hn,hc = num h in
let wn,wc = num w in
`Exact (hn,wn),hc ++ wc
| `Inside (h,w) ->
let hn,hc = num h in
let wn,wc = num w in
`Inside (hn,wn),hc++wc
| `Height h ->
let hn,hc = num h in
`Height hn,hc
| `Width w ->
let wn,wc = num w in
`Width wn,wc
| `None -> `None,C.CSeq []
in code++C.CExternalImage (filename,spec)
let reset () =
D.PthM.clear D.path_map;
D.PthM.clear path_names;
D.PicM.clear D.picture_map;
D.PicM.clear picture_names
mlpost-0.8.2/compiled_types.ml 0000664 0000000 0000000 00000006065 13060465153 0016423 0 ustar 00root root 0000000 0000000 (**************************************************************************)
(* *)
(* Copyright (C) Johannes Kanig, Stephane Lescuyer *)
(* Jean-Christophe Filliatre, Romain Bardou and Francois Bobot *)
(* *)
(* This software is free software; you can redistribute it and/or *)
(* modify it under the terms of the GNU Library General Public *)
(* License version 2.1, with the special exception on linking *)
(* described in file LICENSE. *)
(* *)
(* This software is distributed in the hope that it will be useful, *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *)
(* *)
(**************************************************************************)
type num = float
and point = Point_lib.t
and direction =
| Vec of point
| Curl of float
| NoDir
and joint =
| JLine
| JCurve
| JCurveNoInflex
| JTension of float * float
| JControls of point * point
and knot = direction * point * direction
and path =
| PAScope of path
| PAConcat of knot * joint * path
| PACycle of direction * joint * path
| PAFullCircle
| PAHalfCircle
| PAQuarterCircle
| PAUnitSquare
| PATransformed of path * transform
| PAKnot of knot
| PAAppend of path * joint * path
| PACutAfter of path * path
| PACutBefore of path * path
| PABuildCycle of path list
(* PASub only takes a name *)
| PASub of num * num * name
| PABBox of picture
| PAName of name
and matrix = Types.matrix
and transform = name
and picture =
| PITex of string
| PITransformed of picture * transform
| PIName of name
and dash =
| DEvenly
| DWithdots
| DScaled of num * dash
| DShifted of point * dash
| DPattern of on_off list
and pen =
| PenCircle
| PenSquare
| PenFromPath of path
| PenTransformed of pen * transform
and command =
| CDraw of path * color option * pen option * dash option
| CDrawArrow of path * color option * pen option * dash option
| CDrawPic of picture
| CFill of path * color option
| CLabel of picture * position * point
| CDotLabel of picture * position * point
| CSeq of command list
| CDeclPath of name * path
| CDeclPoint of name * point
| CDeclNum of name * num
| CDefPic of name * command
| CDefTrans of name * matrix
| CSimplePic of name * picture
| CClip of name * path
| CExternalImage of string * spec_image
and spec_image =
[ `None
| `Width of num (* keep the proportion of the image *)
| `Height of num
| `Inside of num * num (* must be inside a box of this height and width *)
| `Exact of num * num]
and color = Types.color
and position = Types.position
and name = Types.name
and on_off =
| On of num | Off of num
mlpost-0.8.2/concrete.ml 0000664 0000000 0000000 00000012507 13060465153 0015203 0 ustar 00root root 0000000 0000000 (**************************************************************************)
(* *)
(* Copyright (C) Johannes Kanig, Stephane Lescuyer *)
(* Jean-Christophe Filliatre, Romain Bardou and Francois Bobot *)
(* *)
(* This software is free software; you can redistribute it and/or *)
(* modify it under the terms of the GNU Library General Public *)
(* License version 2.1, with the special exception on linking *)
(* described in file LICENSE. *)
(* *)
(* This software is distributed in the hope that it will be useful, *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *)
(* *)
(**************************************************************************)
IFDEF CONCRETE THEN
let supported = true
type cnum = float
let set_verbosity = Defaults.set_verbosity
let set_prelude = Defaults.set_prelude_from_file
let set_prelude2 s =
let s = match s with None -> "" | Some s -> s in
Defaults.set_prelude s
let set_t1disasm = Defaults.set_t1disasm
module CPoint = Point_lib
module CPath =
struct
module S = Spline_lib
type t = S.path
type abscissa = float
let length p = float (S.length p)
let is_closed = S.is_closed
let is_a_point x = S.is_a_point x
let intersection p1 p2 = S.intersection p1 p2
let one_intersection p1 p2 = S.one_intersection p1 p2
let reverse = S.reverse
let iter = S.iter
let fold_left = S.fold_left
let cut_before = S.cut_before
let cut_after = S.cut_after
let split = S.split
let subpath = S.subpath
let direction_of_abscissa = S.direction_of_abscissa
let point_of_abscissa = S.abscissa_to_point
let bounding_box = S.bounding_box
let dist_min_point = S.dist_min_point
let dist_min_path = S.dist_min_path
let print = S.print
end
module CTransform = Matrix
let float_of_num = Compute.num
let cpoint_of_point = Compute.point
let cpath_of_path = Compute.path
let ctransform_of_transform = Compute.transform
let baselines s = Picture_lib.baseline (Compute.picture (Types.mkPITex s))
let num_of_float = Misc.id
let point_of_cpoint = Misc.id
let path_of_cpath p =
let knot x = Types.mkKnot Types.mkNoDir (point_of_cpoint x) Types.mkNoDir in
let start = knot (CPath.point_of_abscissa p 0.) in
let path = CPath.fold_left
(fun acc _ b c d ->
let joint = Types.mkJControls (point_of_cpoint b) (point_of_cpoint c) in
Types.mkMPAConcat (knot d) joint acc
) (Types.mkMPAKnot start) p in
if CPath.is_closed p
then Types.mkMPACycle Types.mkNoDir Types.mkJLine path
else Types.mkPAofMPA path
let transform_of_ctransform x = [x]
ELSE
let supported = false
let not_supported s = failwith ("Concrete."^s^" : not supported")
module CPoint =
struct
let not_supported s = failwith ("Concrete.Cpoint."^s^" : not supported")
type t = {x:float; y:float}
let add _ _ = not_supported "add"
let sub _ _ = not_supported "sub"
let opp _ = not_supported "opp"
let mult _ _ = not_supported "mult"
let div _ _ = not_supported "div"
module Infix =
struct
let (+/) = add
let (-/) = sub
let ( */) = mult
let ( //) = div
end
let print _ _ = not_supported "print"
end
module CPath =
struct
let not_supported s = failwith ("Concrete.CPath."^s^" : not supported")
type t = unit
type abscissa = float
type point = CPoint.t
let length _ = not_supported "length"
let is_closed _ = not_supported "is_closed"
let is_a_point _ = not_supported "is_a_point"
let intersection p1 p2 = not_supported "intersection"
let one_intersection p1 p2 = not_supported "one_intersection"
let reverse _ = not_supported "reverse"
let iter _ _ = not_supported "iter"
let fold_left _ _ = not_supported "fold_left"
let cut_before _ _ = not_supported "cut_before"
let cut_after _ _ = not_supported "cut_after"
let split p t = not_supported "split"
let subpath p t1 t2 = not_supported "subpath"
let direction_of_abscissa p t1 = not_supported "direction_of_abscissa"
let point_of_abscissa p t1 = not_supported "point_of_abscissa"
let bounding_box _ = not_supported "bounding_box"
let dist_min_point path point = not_supported "dist_min_point"
let dist_min_path path1 path2 = not_supported "dist_min_path"
let print _ _ = not_supported "print"
end
module CTransform =
struct
type t =
{ xx : float; yx : float;
xy : float; yy : float; x0 : float; y0 : float; }
end
let float_of_num _ = not_supported "float_of_num"
let compute_nums _ = not_supported "compute_nums"
let cpoint_of_point _ = not_supported "cpoint_of_point"
let cpath_of_path _ = not_supported "cpath_of_path"
let ctransform_of_transform _ = not_supported "ctransform_of_transform"
let num_of_float f = not_supported "num_of_float"
let point_of_cpoint p = not_supported "point_of_cpoint"
let path_of_cpath p = not_supported "path_of_cpath"
let transform_of_ctransform _ = not_supported "transform_of_ctransform"
let baselines p = not_supported "baselines"
END
mlpost-0.8.2/concrete/ 0000775 0000000 0000000 00000000000 13060465153 0014644 5 ustar 00root root 0000000 0000000 mlpost-0.8.2/concrete/_tags 0000664 0000000 0000000 00000000115 13060465153 0015661 0 ustar 00root root 0000000 0000000 : pkg_cairo
: syntax_macro
<*.cmx> : for-pack(Mlpost)
mlpost-0.8.2/concrete/compute.ml 0000664 0000000 0000000 00000025255 13060465153 0016663 0 ustar 00root root 0000000 0000000 (**************************************************************************)
(* *)
(* Copyright (C) Johannes Kanig, Stephane Lescuyer *)
(* Jean-Christophe Filliatre, Romain Bardou and Francois Bobot *)
(* *)
(* This software is free software; you can redistribute it and/or *)
(* modify it under the terms of the GNU Library General Public *)
(* License version 2.1, with the special exception on linking *)
(* described in file LICENSE. *)
(* *)
(* This software is distributed in the hope that it will be useful, *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *)
(* *)
(**************************************************************************)
module P = Point_lib
module M = Matrix
let default_labeloffset = 3.5 (* should be 3. but not enough*)
let default_pen = M.scale 0.5
let bbox_offset = {P.x=2.;P.y=2.}
let pi = 3.1415926535897932384626433832795029
let pi_div_180 = pi /. 180.0
let deg2rad f = pi_div_180 *. f
open Types
open Hashcons
module S = Spline_lib
module Pi = Picture_lib
module MP = Metapath_lib
let memoize f fname memoize =
fun arg ->
try Hashtbl.find memoize arg.tag
with Not_found ->
let result =
try f arg.node
with exn ->
if Defaults.get_debug () then
Format.printf "Compute.%s raises : %s@.@?"
fname (Printexc.to_string exn);
raise exn
in
Hashtbl.add memoize arg.tag result;
result
let nop = Picture_lib.empty
let option_compile f = function
| None -> None
| Some obj -> Some (f obj)
let option_def_compile def f = function
| None -> def
| Some obj -> f obj
let middle x y = (x/.2.)+.(y/.2.)
let point_of_position ecart
({ P.x = xmin; y = ymin}, { P.x = xmax; y = ymax}) pos =
match pos_reduce pos with
| `North -> {P.x=middle xmin xmax; y=ymax+.ecart}
| `South -> {P.x=middle xmin xmax; y=ymin-.ecart}
| `West -> {P.x=xmin-.ecart; y=middle ymin ymax}
| `East -> {P.x=xmax+.ecart; y=middle ymin ymax}
| `Northwest -> {P.x=xmin-.ecart;y=ymax+.ecart}
| `Northeast -> {P.x=xmax+.ecart;y=ymax+.ecart}
| `Southwest -> {P.x=xmin-.ecart;y=ymin-.ecart}
| `Southeast -> {P.x=xmax+.ecart;y=ymin-.ecart}
| `Center -> {P.x = middle xmin xmax; P.y = middle ymin ymax }
let anchor_of_position pos =
match pos_reduce pos with
| `North -> `South
| `South -> `North
| `West -> `East
| `East -> `West
| `Northwest -> `Southeast
| `Northeast -> `Southwest
| `Southwest -> `Northeast
| `Southeast -> `Northwest
| `Center -> `Center
let metapath_memoize = Hashtbl.create 50
let path_memoize = Hashtbl.create 50
let picture_memoize = Hashtbl.create 50
let command_memoize = Hashtbl.create 50
let clear () =
Hashtbl.clear metapath_memoize;
Hashtbl.clear path_memoize;
Hashtbl.clear picture_memoize;
Hashtbl.clear command_memoize
let float_to_metapost f =
(* Compatibility with metapost *)
if f = infinity then 4095.99998 (* cf mpman *)
else if f > 4095. then 4095.
else if abs_float f < 0.0001 then 0.
else f
let rec num n = n
and point p = p
(*
and point' = function
| PTPair (f1,f2) ->
let f1 = num f1 in
let f2 = num f2 in
{P.x=f1;y=f2}
| PTPointOf (f,p) ->
let p = path p in
let f = Spline_lib.abscissa_of_metapost p (num f) in
Spline_lib.abscissa_to_point p f
| PTDirectionOf (f,p) ->
let p = path p in
let f = Spline_lib.abscissa_of_metapost p (num f) in
Spline_lib.direction_of_abscissa p f
| PTAdd (p1,p2) ->
let p1 = point p1 in
let p2 = point p2 in
P.add p1 p2
| PTSub (p1,p2) ->
let p1 = point p1 in
let p2 = point p2 in
P.sub p1 p2
| PTMult (f,p) ->
let f = num f in
let p1 = point p in
P.mult f p1
| PTRotated (f,p) ->
let p1 = point p in
P.rotated (deg2rad f) p1
| PTPicCorner (pic, corner) ->
let p = commandpic pic in
point_of_position 0. (Picture_lib.bounding_box p) (corner :> position)
| PTTransformed (p,tr) ->
let p = point p in
let tr = transform tr in
P.transform tr p
and point p = memoize point' "point" point_memoize p
*)
and knot k =
match k.Hashcons.node with
| { knot_in = d1 ; knot_p = p ; knot_out = d2 } ->
let d1 = direction d1 in
let p = point p in
let d2 = direction d2 in
let d1,d2 = MP.equalize_dir (d1,d2) in
d1,MP.knot p,d2
and joint dl j dr =
match j.Hashcons.node with
| JLine -> MP.line_joint
| JCurve -> MP.curve_joint dl dr
| JCurveNoInflex -> MP.curve_no_inflex_joint dl dr
| JTension (a,b) -> MP.tension_joint dl a b dr
| JControls (p1,p2) ->
let p1 = point p1 in
let p2 = point p2 in
MP.controls_joint p1 p2
and direction d =
match d.Hashcons.node with
| Vec p ->
let p = point p in
MP.vec_direction p
| Curl f -> MP.curl_direction (float_to_metapost f)
| NoDir -> MP.no_direction
and metapath' = function
| MPAConcat (pa,j,p) ->
let pdl,p,pdr = metapath p in
let dl,pa,dr = knot pa in
let j = joint pdr j dl in
pdl,MP.concat p j pa,dr
| MPAAppend (p1,j,p2) ->
let p1dl,p1,p1dr = metapath p1 in
let p2dl,p2,p2dr = metapath p2 in
let j = joint p1dr j p2dl in
p1dl,MP.append p1 j p2,p2dr
| MPAKnot k ->
let dl,p,dr = knot k in
dl,MP.start p, dr
| MPAofPA p ->
MP.no_direction, MP.from_path (path p), MP.no_direction
and metapath p = memoize metapath' "metapath" metapath_memoize p
and path' = function
| PAofMPA p ->
let _,mp,_ = (metapath p) in
MP.to_path mp
| MPACycle (d,j,p) ->
let d = direction d in
let _,p,dr = metapath p in
let j = joint dr j d in
MP.cycle j p
| PATransformed (p,tr) ->
let p = path p in
let tr = transform tr in
Spline_lib.transform tr p
| PACutAfter (p1,p2) ->
let p1 = path p1 in
let p2 = path p2 in
Spline_lib.cut_after p1 p2
| PACutBefore (p1,p2) ->
let p1 = path p1 in
let p2 = path p2 in
Spline_lib.cut_before p1 p2
| PABuildCycle pl ->
(* let npl = List.map path pl in *)
(* TODO *) assert false
(* Spline_lib.buildcycle npl *)
| PASub (f1, f2, p) ->
let p = path p in
Spline_lib.subpath p (num f1) (num f2)
| PABBox p ->
let p = commandpic p in
let pmin,pmax = Picture_lib.bounding_box p in
let pmin,pmax = P.sub pmin bbox_offset,P.add pmax bbox_offset in
Spline_lib.close
(Spline_lib.create_lines [{P.x = pmin.P.x; y = pmin.P.y};
{P.x = pmin.P.x; y = pmax.P.y};
{P.x = pmax.P.x; y = pmax.P.y};
{P.x = pmax.P.x; y = pmin.P.y}])
| PAUnitSquare -> MP.Approx.unitsquare 1.
| PAQuarterCircle -> MP.Approx.quartercircle 1.
| PAHalfCircle -> MP.Approx.halfcirle 1.
| PAFullCircle -> MP.Approx.fullcircle 1.
and path p = (*Format.printf "path : %a@.@?" Print.path p;*)
memoize path' "path" path_memoize p
and picture' = function
| PITransformed (p,tr) ->
let tr = transform tr in
let pic = commandpic p in
Picture_lib.transform tr pic
| PITex s ->
let tex = Gentex.create s in
Picture_lib.tex tex
| PIClip (pic,pth) ->
let pic = commandpic pic in
let pth = path pth in
Picture_lib.clip pic pth
and picture p = memoize picture' "picture" picture_memoize p
and transform t =
List.fold_left Matrix.multiply Matrix.identity t
and commandpic p =
match p.Hashcons.node with
| Picture p -> picture p
| Command c -> command c
| Seq l ->
begin match l with
| [] -> Picture_lib.empty
| [x] -> commandpic x
| (x::r) ->
List.fold_left
(fun acc c -> Picture_lib.on_top acc (commandpic c)) (commandpic x) r
end
and dash d =
match d.Hashcons.node with
| DEvenly -> Picture_lib.Dash.line
| DWithdots -> Picture_lib.Dash.dots
| DScaled (f, d) ->
let f = num f in
let d = dash d in
Picture_lib.Dash.scale f d
| DShifted (p,d) ->
let p = point p in
let d = dash d in
Picture_lib.Dash.shifted p.P.x d
| DPattern l ->
let l = List.map dash_pattern l in
Picture_lib.Dash.pattern l
and dash_pattern o =
match o.Hashcons.node with
| On f -> Picture_lib.Dash.On (num f)
| Off f -> Picture_lib.Dash.Off (num f)
and command' = function
| CDraw (p, b) ->
let p = path p in
let {color = c; pen = pe; dash = dsh} = b.Hashcons.node in
let pe = (option_def_compile default_pen pen) pe in
let dsh = (option_compile dash) dsh in
Picture_lib.stroke_path p c pe dsh
| CFill (p, c) ->
let p = path p in
Picture_lib.fill_path p c
| CDotLabel (pic, pos, pt) ->
Picture_lib.on_top (Picture_lib.draw_point (point pt))
(command (mkCLabel pic pos pt))
| CLabel (pic, pos ,pt) ->
let pic = commandpic pic in
let pt = point pt in
let mm = (Picture_lib.bounding_box pic) in
let anchor = anchor_of_position pos in
let pos = (point_of_position default_labeloffset mm anchor) in
let tr = Matrix.translation (P.sub pt pos) in
Picture_lib.transform tr pic
| CExternalImage (filename,sp) ->
Picture_lib.external_image filename (spec sp)
and spec = function
| `Exact (n1,n2) -> `Exact (num n1, num n2)
| `Height n -> `Height (num n)
| `Width n -> `Width (num n)
| `Inside (n1,n2) -> `Inside (num n1, num n2)
| `None -> `None
and pen p =
(* TODO : the bounding box is not aware of the pen size *)
match p.Hashcons.node with
| PenCircle -> Matrix.identity
| PenSquare -> (*TODO not with cairo...*)assert false
(*Picture_lib.PenSquare*)
| PenFromPath p -> (*TODO : very hard*)assert false
(*Picture_lib.PenFromPath (path p)*)
| PenTransformed (p, tr) ->
Matrix.multiply (transform tr) (pen p)
and command c = memoize command' "command" command_memoize c
let commandl_error ferror arg = List.map (ferror command) arg
let commandpicl_error ferror arg = List.map (ferror commandpic) arg
let numl_error ferror arg = List.map (ferror num) arg
let pointl_error ferror arg = List.map (ferror point) arg
let pathl_error ferror arg = List.map (ferror path) arg
let metapathl_error ferror arg = List.map (ferror metapath) arg
let picturel_error ferror arg = List.map (ferror picture) arg
mlpost-0.8.2/concrete/concrete_types.ml 0000664 0000000 0000000 00000000256 13060465153 0020227 0 ustar 00root root 0000000 0000000 type scolor =
| RGB of float * float * float
| CMYK of float * float * float * float
| Gray of float
type color =
|OPAQUE of scolor
|TRANSPARENT of float * scolor
mlpost-0.8.2/concrete/ctypes.mli 0000664 0000000 0000000 00000000523 13060465153 0016656 0 ustar 00root root 0000000 0000000 IFDEF CAIRO THEN
type matrix = Cairo.matrix =
{ xx : float; yx : float; xy : float; yy : float; x0 : float; y0 : float; }
type point = Cairo.point =
{x : float;
y : float}
ELSE
type matrix =
{ xx : float; yx : float; xy : float; yy : float; x0 : float; y0 : float; }
type point = {x : float; y : float}
END
mlpost-0.8.2/concrete/gentex.ml 0000664 0000000 0000000 00000013533 13060465153 0016475 0 ustar 00root root 0000000 0000000 (**************************************************************************)
(* *)
(* Copyright (C) Johannes Kanig, Stephane Lescuyer *)
(* Jean-Christophe Filliatre, Romain Bardou and Francois Bobot *)
(* *)
(* This software is free software; you can redistribute it and/or *)
(* modify it under the terms of the GNU Library General Public *)
(* License version 2.1, with the special exception on linking *)
(* described in file LICENSE. *)
(* *)
(* This software is distributed in the hope that it will be useful, *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *)
(* *)
(**************************************************************************)
open Printf
open Point_lib
let com_latex = "latex"
let jobname = "gentex"
let filename = File.from_string jobname
(* FIXME different from Metapost.default_prelude? *)
let latex_cmd tmpdir =
Printf.sprintf "latex -jobname=%s -ipc -halt-on-error -output-dir '%s'"
jobname (File.Dir.to_string tmpdir)
(* Printf.sprintf "cat" *)
type t = {tex : Dviinterp.page;
trans : Matrix.t;
bb : (float * float * float * float)}
let set_verbosity b = ()
type proc = { outc : in_channel; inc : out_channel; errc : in_channel }
type comm = { latex : proc ; dvi : Dvi.Incremental.t; tmpdir : File.Dir.t }
let truncate_or_touch f =
File.open_in_gen [Open_trunc; Open_creat; Open_rdonly] 0o600 f
let ends_with en s =
let l = String.length s in
let k = String.length en in
if k <= l then
try
for i = 0 to k - 1 do
if s.[l - i - 1] <> en.[k - i - 1] then raise Exit
done;
true
with Exit -> false
else false
let read_up_to_one =
(* FIXME deal with EOF exception:
Actually that print on stdout and that throw the error.
Perhaps can we throw an exception with all in it.
But it is not very fun for user (only part of the string in an exception
is printed)
*)
let end_ = "[1]" in
let rec aux buf inc =
let s =
try
input_line inc
with End_of_file ->
Buffer.output_buffer stdout buf;
invalid_arg ("One tex snipet contains an error")
in
Buffer.add_string buf s;
Buffer.add_char buf '\n';
if ends_with end_ s then () else aux buf inc in
fun inc ->
let buf = Buffer.create 10 in
aux buf inc
let read_up_to_one p = read_up_to_one p.outc
let mk_proc_latex tmpdir =
let outc,inc,errc =
Unix.open_process_full (latex_cmd tmpdir) (Unix.environment ()) in
{ outc = outc; inc = inc ; errc = errc }
let write_to_proc p s =
Printf.fprintf p.inc s
let push_prelude p prel =
(* the shipout macro from metapost, that adds a vrule at the end of the tex
* to obtain easily the size of the dvi *)
write_to_proc p
"%s
\\begin{document}
\\gdef\\mpxshipout{\\shipout\\hbox\\bgroup%%
\\setbox0=\\hbox\\bgroup}%%
\\gdef\\stopmpxshipout{\\egroup \\dimen0=\\ht0 \\advance\\dimen0\\dp0
\\dimen1=\\ht0 \\dimen2=\\dp0
\\setbox0=\\hbox\\bgroup
\\box0
\\ifnum\\dimen0>0 \\vrule width1sp height\\dimen1 depth\\dimen2
\\else \\vrule width1sp height1sp depth0sp\\relax
\\fi\\egroup
\\ht0=0pt \\dp0=0pt \\box0 \\egroup}\n%!" prel
let shipout_and_flush p s =
write_to_proc p "\\mpxshipout %s\\stopmpxshipout\n%!" s
let end_doc p =
write_to_proc p "\\end{document}\n%!"
let extract cl =
(* the vrule added by the metapost shipout macro is exploited and removed *)
match cl with
| Dviinterp.Fill_rect (_,x,y,_,h)::cl ->
let bb = (0., -.(y+.h), x, -.y) in
{tex = cl; trans = Matrix.identity; bb = bb}
| _ -> assert false
let comm = ref None
(* TODO : do that only when clean is requested.
note if an error occured comm become None
*)
let () = at_exit (fun () ->
match !comm with
| None -> ()
| Some p -> File.Dir.rm p.tmpdir)
let read_up_to_one p =
try
read_up_to_one p
with e -> comm := None;raise e
let create tex =
(* FIXME at some point we have to close the latex process *)
match !comm with
| None ->
let tmpdir = Metapost_tool.create_temp_dir "mlpost" "" in
let p = mk_proc_latex tmpdir in
push_prelude p (Defaults.get_prelude ());
shipout_and_flush p tex;
read_up_to_one p;
let filename = File.place tmpdir (File.set_ext filename "dvi") in
let dvi_chan = File.open_in filename in
let t, pgs = Dvi.Incremental.mk_t dvi_chan in
comm := Some { latex = p ; dvi = t ; tmpdir = tmpdir};
extract (Dviinterp.Incremental.load_page t (List.hd pgs))
| Some p ->
shipout_and_flush p.latex tex;
read_up_to_one p.latex;
let pgs = Dvi.Incremental.next_pages p.dvi in
extract (Dviinterp.Incremental.load_page p.dvi (List.hd pgs))
let point_of_cm cm = (0.3937 *. 72.) *. cm
let get_dimen_cm x = x.bb
let get_dimen_pt x =
let (x_min,y_min,x_max,y_max) = get_dimen_cm x in
(point_of_cm x_min,
point_of_cm y_min,
point_of_cm x_max,
point_of_cm y_max)
(** donne la dimension en centimètre *)
let get_bases_cm x = assert false
let get_bases_pt x = assert false
let bounding_box x =
let (xmin,ymin,xmax,ymax) = get_dimen_pt x in
if Defaults.get_debug () then
Format.printf "gentex bb : %f %f %f %f@." xmin ymin xmax ymax;
{x=xmin;y=ymin},{x=xmax;y=ymax}
let print fmt tex =
let min,max = bounding_box tex in
Format.fprintf fmt "[%a,%a]" print min print max
let deb_print fmt tex =
Format.printf "{ tex: %a ; matrix: %a }" Dviinterp.Print.page tex.tex
Matrix.print tex.trans
mlpost-0.8.2/concrete/gentex.mli 0000664 0000000 0000000 00000003231 13060465153 0016640 0 ustar 00root root 0000000 0000000 (**************************************************************************)
(* *)
(* Copyright (C) Johannes Kanig, Stephane Lescuyer *)
(* Jean-Christophe Filliatre, Romain Bardou and Francois Bobot *)
(* *)
(* This software is free software; you can redistribute it and/or *)
(* modify it under the terms of the GNU Library General Public *)
(* License version 2.1, with the special exception on linking *)
(* described in file LICENSE. *)
(* *)
(* This software is distributed in the hope that it will be useful, *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *)
(* *)
(**************************************************************************)
val set_verbosity : bool -> unit
type t = {tex : Dviinterp.page ;
trans : Matrix.t;
bb : (float * float * float * float)}
val create : string -> t
val get_dimen_pt : t -> float * float * float * float
val get_dimen_cm : t -> float * float * float * float
val bounding_box : t -> Point_lib.t * Point_lib.t
val get_bases_pt : t -> float list
val get_bases_cm : t -> float list
val print : Format.formatter -> t -> unit
val deb_print : Format.formatter -> t -> unit
(** donne la dimension en centimètre *)
mlpost-0.8.2/concrete/matrix.ml 0000664 0000000 0000000 00000005666 13060465153 0016517 0 ustar 00root root 0000000 0000000 (**************************************************************************)
(* *)
(* Copyright (C) Johannes Kanig, Stephane Lescuyer *)
(* Jean-Christophe Filliatre, Romain Bardou and Francois Bobot *)
(* *)
(* This software is free software; you can redistribute it and/or *)
(* modify it under the terms of the GNU Library General Public *)
(* License version 2.1, with the special exception on linking *)
(* described in file LICENSE. *)
(* *)
(* This software is distributed in the hope that it will be useful, *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *)
(* *)
(**************************************************************************)
open Ctypes
type point = Ctypes.point
type t = matrix =
{ xx : float; yx : float; xy : float; yy : float; x0 : float; y0 : float; }
(* specialized negation here to avoid dependency *)
let neg_point p =
{ x = -.p.x; y = -.p.y}
let linear xx xy yx yy =
{ xx = xx; xy = xy; yx = yx; yy = yy; x0 = 0.; y0 = 0. }
(*
let scale_mult m f =
{ xx = m.xx *. f;
xy = m.xy *. f;
yx = m.yx *. f;
yy = m.yy *. f;
x0 = m.x0 *. f;
y0 = m.y0 *. f;
}
*)
let init_translate x y =
{ xx = 1.; yx = 0.; xy = 0.; yy = 1.; x0 = x; y0 = y }
let init_scale x y =
{ xx = x; yx = 0.; xy = 0.; yy = y; x0 = 0.; y0 = 0. }
let init_identity =
{ xx = 1.; yx = 0.; xy = 0.; yy = 1.; x0 = 0.; y0 = 0. }
let init_rotate a =
let s = sin a in
let c = cos a in
{ xx = c; yx = s; xy = -.s; yy = c; x0 = 0.; y0 = 0. }
let multiply a b =
{ xx = a.xx *. b.xx +. a.yx *. b.xy ;
yx = a.xx *. b.yx +. a.yx *. b.yy;
xy = a.xy *. b.xx +. a.yy *. b.xy;
yy = a.xy *. b.yx +. a.yy *. b.yy;
x0 = a.x0 *. b.xx +. a.y0 *. b.xy +. b.x0;
y0 = a.x0 *. b.yx +. a.y0 *. b.yy +. b.y0;
}
let translate m tx ty =
multiply (init_translate tx ty) m
let translation p = init_translate p.x p.y
let xy_translation x y = init_translate x y
let rotation = init_rotate
let scale f = init_scale f f
let xscaled f = init_scale f 1.
let yscaled f = init_scale 1. f
let slanted f = linear 1. f 0. 1.
let zscaled p = linear p.x (0. -. p.y) p.y p.x
let reflect p1 p2 = (*TODO *) assert false
let rotate m f =
multiply (init_rotate f) m
let rotate_around p f =
translate (rotate (translation (neg_point p)) f) p.x p.y
let to_cairo x = x
let identity = init_identity
let remove_translation t = { t with x0 = 0.; y0 = 0.}
let print fmt m =
Format.fprintf fmt "[|[|%f;%f|];[|%f;%f|];[|%f;%f|]|]"
m.xx m.xy m.yx m.yy m.x0 m.y0
mlpost-0.8.2/concrete/matrix.mli 0000664 0000000 0000000 00000001130 13060465153 0016646 0 ustar 00root root 0000000 0000000 type point = Ctypes.point
type t = Ctypes.matrix =
{ xx : float; yx : float; xy : float; yy : float; x0 : float; y0 : float; }
val scale : float -> t
val rotation : float -> t
val xscaled : float -> t
val yscaled : float -> t
val slanted : float -> t
val translation : point -> t
val zscaled : point -> t
val reflect : point -> point -> t
val rotate_around : point -> float -> t
val identity : t
val multiply : t -> t -> t
val xy_translation : float -> float -> t
val remove_translation : t -> t
val linear : float -> float -> float -> float -> t
val print : Format.formatter -> t -> unit
mlpost-0.8.2/concrete/metapath_lib.ml 0000664 0000000 0000000 00000053023 13060465153 0017632 0 ustar 00root root 0000000 0000000 (**************************************************************************)
(* *)
(* Copyright (C) Johannes Kanig, Stephane Lescuyer *)
(* Jean-Christophe Filliatre, Romain Bardou and Francois Bobot *)
(* *)
(* This software is free software; you can redistribute it and/or *)
(* modify it under the terms of the GNU Library General Public *)
(* License version 2.1, with the special exception on linking *)
(* described in file LICENSE. *)
(* *)
(* This software is distributed in the hope that it will be useful, *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *)
(* *)
(**************************************************************************)
module P = Point_lib
open Point_lib
open Point_lib.Infix
module S = Spline_lib
exception Not_implemented of string
let not_implemented s = raise (Not_implemented s)
let square x = x *. x
let debug = false
let info = debug || false
type point = P.t
type direction =
| DVec of point
| DCurl of float
| DNo
type joint =
| JLine
| JCurve of direction * direction
| JCurveNoInflex of direction * direction
| JTension of direction * float * float * direction
| JControls of point * point
type knot = point
type t =
| Start of knot
| Cons of t * joint * knot
| Start_Path of Spline.t list
| Append_Path of t * joint * (Spline.t list)
open Format
let rec print_dir fmt = function
|DNo -> fprintf fmt "DNo"
|DVec p -> fprintf fmt "DVec %a" Point_lib.print p
|DCurl f -> fprintf fmt "Dcurl %f" f
and print_knot = Point_lib.print
and print_joint fmt = function
| JLine -> fprintf fmt "JLine"
| JCurve (d1,d2) -> fprintf fmt "JCurve(%a,%a)" print_dir d1 print_dir d2
| JCurveNoInflex _ -> fprintf fmt "JCurveNoInflex"
| JTension (_,f1,f2,_) -> fprintf fmt "JTension (%f,%f)" f1 f2
| JControls (p1,p2) ->
fprintf fmt "JControls (%a,%a)" Point_lib.print p1 Point_lib.print p2
and print fmt = function
| Start k1 -> fprintf fmt "[%a" print_knot k1
| Cons (p,j,k) -> fprintf fmt "%a;%a-%a" print p print_joint j print_knot k
| Start_Path p-> fprintf fmt "{%a}" S.print_splines p
| Append_Path (p1,j,p2) ->
fprintf fmt "%a;%a-%a" print p1 print_joint j S.print_splines p2
type tension = float
let tunity:tension = 1.
(* Metafont is wiser in the computation of
calc_value, calc_ff, curl_ratio, ... *)
(* dk1, uk1 are d_k-1, u_k-1 *)
(* ((3-α)α²γ + β³) / ( α³γ + (3-β)β²) *)
let curl_ratio gamma alpha1 beta1 =
let alpha = 1./.alpha1 and beta = 1./.beta1 in
let gamma = if alpha <= beta
then gamma *.square (alpha /. beta) else gamma in
let beta = if alpha <= beta then beta else beta *. square (beta /. alpha) in
(gamma *. (3. -. alpha) +. beta) /. (alpha *. gamma +. 3. -. beta)
let reduce_angle x =
(* 292. define reduce angle (#) *)
if (abs_float x) > 180.
then if x>0. then x -. 360. else x +. 360.
else x
let velocity st ct sf cf t =
let num =
(* 2 + √2(st - sf/16)(sf - st/16) * (ct -cf) *)
2. +. (sqrt 2.) *. (st -. (sf /. 16.)) *.
(sf -. (st /. 16.)) *. (ct -. cf) in
let denom =
(* 3(1+1/2(√5 - 1))ct + 1/2(3-√5)cf *)
3. *. (1. +. 0.5 *. ((sqrt 5.) -. 1.) *. ct +.
0.5 *. (3. -. (sqrt 5.)) *. cf) in
min ((num /. t) /. denom) 4.
let calc_value dk1 dk art alt uk1 =
(* Calculate the values aa = Ak /Bk , bb = Dk /Ck ,
dd = (3 - k-1 )dk,k+1 , ee = (3 - k+1 )dk-1,k , and
cc = (Bk - uk-1 Ak )/Bk 288 *)
let aa = 1./.(3.*.art -. 1.) in
let bb = 1./.(3.*.alt -. 1.) in
let cc = 1.-.(uk1*.aa) in
let dd = dk*.(3.-.(1./.art)) in
let ee = dk1*.(3.-.(1./.alt)) in
aa,bb,cc,dd,ee
let calc_ff cc dd ee art alt =
(* Calculate the ratio ff = Ck /(Ck + Bk - uk-1 Ak ) 289 *)
if alt < art then ee /. (ee +. cc *. dd *. (alt /. art)**2.)
else let ee = ee *. (art /. alt)**2. in
ee /. (ee +. cc *. dd)
type path_type =
| Endpoint
| Explicit of point
| Open of tension
| Endcycle of tension
| Curl of tension * float
| Given of tension * float
let tension = function
| Endpoint -> 1. (* not sure ... *)
| Explicit _ -> assert false
| Open t | Endcycle t | Curl (t,_) | Given (t,_) -> t
type kpath = {
mutable left : path_type;
mutable right : path_type;
mutable link : kpath;
mutable coord : point}
let dumb_pos = {x=666.;y=42.}
let dumb_dir = Endcycle 42.
let rec dumb_link = { left = dumb_dir;
right = dumb_dir;
coord = dumb_pos;
link = dumb_link}
let mk_kpath ?(left=dumb_dir) ?(right=dumb_dir)
?(link=dumb_link) ?(coord=dumb_pos) () =
{ left = left; right = right; link = link; coord = coord }
let print_path_type fmt = function
| Endpoint -> fprintf fmt "Endpoint"
| Explicit p -> fprintf fmt "Explicit %a" P.print p
| Open t -> fprintf fmt "Open %f" t
| Endcycle t -> fprintf fmt "Endcycle %f" t
| Curl (t,f) -> fprintf fmt "Curl (%f,%f)" t f
| Given (t,f) -> fprintf fmt "Given (%f,%f)" t f
let print_one_kpath fmt q =
fprintf fmt "@[{left = @[%a@];@,coord = @[%a@];@,right = @[%a@]}@]"
print_path_type q.left
P.print q.coord
print_path_type q.right
let print_kpath fmt p =
let rec aux fmt q =
fprintf fmt
"@[{left = @[%a@];@,coord = @[%a@];@,right = @[%a@];@,link= @[%a@]}@]"
print_path_type q.left
P.print q.coord
print_path_type q.right
(fun fmt q ->
if q!=p && q!=dumb_link
then aux fmt q
else fprintf fmt "...") q.link in
aux fmt p
let pi = acos (-.1.)
let n_arg =
let coef = 180./.pi in
fun p -> (atan2 p.y p.x)*.coef
let sincos =
let coef = pi/.180. in
fun a -> let a = coef *. a in
sin a, cos a
let set_controls p q at af rtension ltension deltaxy =
(* procedure set controls (p, q : pointer ; k : integer ) 299 *)
let st,ct = at in
let sf,cf = af in
let rr = velocity st ct sf cf (abs_float rtension) in
let ss = velocity sf cf st ct (abs_float ltension) in
let rr, ss =
(* Decrease the velocities if necessary 300 *)
if (rtension < 0. || ltension < 0.) &&
((st >= 0. && sf >= 0.) || (st <= 0. && sf <= 0.)) then begin
let sine = 2. *. cf *. abs_float st +. cf *. abs_float sf in
if sine > 0. then
let choice t s k =
let sa = abs_float s in
if t< 0. && sa < k *. sine then sa /. sine else k in
choice rtension sf rr, choice ltension st ss
else rr,ss
end else rr, ss
in
let sb = p.coord +/ rr*/ (ct */ deltaxy +/ st */ P.swapmy deltaxy) in
p.right <- Explicit sb;
let sc = q.coord -/ ss */ (cf */ deltaxy +/ sf */ P.swapmx deltaxy) in
q.left <- Explicit sc
let print_array print fmt =
Array.iter (fun e -> fprintf fmt "%a;@," print e)
let print_float fmt = fprintf fmt "%f"
let solve_choices p q n deltaxyk deltak psik =
(* If Only one simple arc*)
match p with
| {right = Given (rt,rp);link={left=Given (lt,lq)}} ->
(* Reduce to simple case of two givens and return 301 *)
let aa = n_arg deltaxyk.(0) in
let at = sincos (rp -. aa) in
let saf,caf = sincos (lq -. aa) in let af = -.saf,caf in
set_controls p q at af rt lt deltaxyk.(0)
| {right = Curl (tp,cp);link={left=Curl (tq,cq)}} ->
(* Reduce to simple case of straight line and return 302 *)
let lt = abs_float tq and rt = abs_float tp in
let tmp = P.sign deltaxyk.(0) in
let fx p t f =
let d = if t = tunity then deltaxyk.(0) +/ tmp else deltaxyk.(0) in
Explicit (f p.coord (d // (3. *. t)) ) in
p.right <- fx p rt (+/);
q.left <- fx q lt (-/);
| {link=t} as s ->
let thetak = Array.make (n+2) 0. in
let uu = Array.make (n+1) 0. in
let vv = Array.make (n+1) 0. in
let ww = Array.make (n+1) 0. in
let curl_eq lt rt cc =
(* Set up the equation for a curl 294 / 295 *)
let lt = abs_float lt and rt = abs_float rt in
if lt = tunity && rt = tunity then (2. *. cc +. 1.) /. (cc +. 2.)
else curl_ratio cc rt lt in
begin
match p with
|{right=Given (_,rp)} ->
(* Set up the equation for a given value of 0 293 *)
vv.(0) <- reduce_angle (rp -. n_arg deltaxyk.(0));
uu.(0) <- 0.; ww.(0) <- 0.
|{right=Curl (tp,cc);link={left=lt}} ->
uu.(0) <- curl_eq (tension lt) tp cc;
vv.(0) <- -. (psik.(1) *. uu.(0));
ww.(0) <- 0.
|{right=Open _} -> uu.(0) <- 0.;vv.(0) <- 0.;ww.(0) <- 1.
| _ ->
(* { there are no other cases } in 285 because of 273 *)
assert false
end;
(let rec aux k r = function
(* last point*)
| {left=Curl (t,cc)} ->
let ff = curl_eq t (tension r.right) cc in
thetak.(n) <- -.((vv.(n-1)*.ff) /. (1.-.ff *. uu.(n-1)))
| {left=Given (_,f)} ->
(* Calculate the given value of n and goto found 292 *)
thetak.(n) <- reduce_angle (f -. n_arg deltaxyk.(n-1))
| {link=t} as s->
(*end cycle , open : Set up equation to match mock curvatures
at zk ; then goto found with n adjusted to equal 0 , if a
cycle has ended 287 *)
let art = abs_float (tension r.right) in
let alt = abs_float (tension t.left) in
let aa,bb,cc,dd,ee =
calc_value deltak.(k-1) deltak.(k) art alt uu.(k-1) in
let art = abs_float (tension s.right) in
let alt = abs_float (tension s.left) in
let ff = calc_ff cc dd ee art alt in
uu.(k)<- ff*.bb;
(* Calculate the values of vk and wk 290 *)
let acc = -. (psik.(k+1)*.uu.(k)) in
(match r.right with
| Curl _ -> (*k=1...*) ww.(k) <- 0.;
vv.(k) <- acc -. (psik.(1) *. (1. -. ff))
| _ ->
let ff = (1. -. ff)/. cc in
let acc = acc -. (psik.(k) *. ff) in
let ff = ff*.aa in
vv.(k) <- acc -. (vv.(k-1)*.ff);
ww.(k) <- -. (ww.(k-1)*.ff));
(match s.left with
| Endcycle _ ->
(* Adjust n to equal 0 and goto found 291 *)
let aa,bb =
(let rec aux aa bb = function
| 0 -> (vv.(n) -. (aa*.uu.(n))),
(ww.(n) -. (bb*.uu.(n)))
| k -> aux (vv.(k) -. (aa*.uu.(k)))
(ww.(k) -. (bb*.uu.(k))) (k-1) in
aux 0. 1. (n-1)) in
let aa = aa /. (1. -. bb) in
thetak.(n) <- aa;
vv.(0) <- aa;
for k = 1 to n-1 do
vv.(k) <- vv.(k) +. (aa*.ww.(k));
done;
| _ -> aux (k+1) s t);
in aux 1 s t);
(* Finish choosing angles and assigning control points 297 *)
for k = n-1 downto 0 do
thetak.(k) <- vv.(k) -. (thetak.(k+1) *. uu.(k))
done;
(let rec aux k = function
| _ when k = n -> ()
| {right=rt;link={left=lt} as t} as s ->
let at = sincos thetak.(k) in
let af = sincos (-.psik.(k+1) -. thetak.(k+1)) in
set_controls s t at af (tension rt) (tension lt) deltaxyk.(k);
aux (k+1) t
in aux 0 p)
let make_choices knots =
(* If consecutive knots are equal, join them explicitly 271*)
(let p = ref knots in
while !p != knots do
(match !p with
| ({coord=coord;right=(Given _|Curl _|Open _);link=q} as k)
when coord == q.coord ->
if debug then
Format.printf "@[find consecutive knots :k = @[%a@];\
@,q = @[%a@]@]@."
print_one_kpath k print_one_kpath q;
k.right <- Explicit coord;
q.left <- Explicit coord;
(match k.left with
| Open tension -> k.left <- Curl (tension,tunity)
| _ -> ());
(match k.right with
| Open tension -> k.right <- Curl (tension,tunity)
| _ -> ());
| _ -> ());
p:=(!p).link;
done);
(*Find the first breakpoint, h, on the path;
insert an artificial breakpoint if the path is an unbroken cycle 272*)
let h =
(let rec aux = function
| {left = (Endpoint | Endcycle _ | Explicit _ | Curl _ | Given _)}
| {right= (Endpoint | Endcycle _ | Explicit _ | Curl _ | Given _)}
as h -> h
| {left = Open t} as h when h==knots -> knots.left <- Endcycle t; knots
| {link=h} -> aux h in
aux knots) in
if debug then
Format.printf "@[find h :h = @[%a@]@]@."
print_one_kpath h;
(*repeat Fill in the control points between p and the next breakpoint,
then advance p to that
breakpoint 273
until p = h*)
(let rec aux = function
| {right =(Endpoint|Explicit _);link = q} -> if q!=h then aux q
| p -> let n,q =
(let rec search_q n = function
|{left=Open _;right=Open _;link=q} -> search_q (n+1) q
| q -> (n,q) in
search_q 1 p.link) in
if debug then
Format.printf "@[search_q : n = %i;@,p = @[%a@];@,q = @[%a@]@]@."
n print_one_kpath p print_one_kpath q;
(*Fill in the control information between consecutive breakpoints
p and q 278*)
(* Calculate the turning angles k and the distances dk,k+1 ;
set n to the length of the path 281*)
let deltaxyk = Array.make (n+1) P.zero in
(* Un chemin sans cycle demande un tableau de taille n,
de n+1 avec cycle *)
let deltak = Array.make (n+1) 0. in
let psik = Array.make (n+2) 0. in
(let rec fill_array k = function
(* K. utilise des inégalitées pour k=n et k = n+1 -> k>=n*)
| s when k = n && (match s.left with
|Endcycle _ -> false | _ -> true) -> psik.(n) <- 0.
(* On a fait un tour le s.left précédent était un Endcycle *)
| _ when k = n+1 -> psik.(n+1)<-psik.(1)
| {link=t} as s ->
deltaxyk.(k) <- t.coord -/ s.coord;
deltak.(k) <- P.norm deltaxyk.(k);
(if k > 0 then
let {x=cosine;y=sine} = deltaxyk.(k-1) // deltak.(k-1) in
let m = Matrix.linear cosine sine (-. sine) cosine in
let psi = n_arg (Point_lib.transform m deltaxyk.(k)) in
psik.(k) <- psi);
fill_array (k+1) t
in fill_array 0 p);
if debug then
(Format.printf "deltaxyk : %a@." (print_array P.print) deltaxyk;
Format.printf "deltak : %a@." (print_array print_float) deltak;
Format.printf "psik : %a@." (print_array print_float) psik);
(*Remove open types at the breakpoints 282*)
(match q with
| {left=Open t} -> q.left <- Curl (t,1.) (* TODO cas bizarre *)
| _ -> ());
(match p with
| {left=Explicit pe;right=Open t} ->
let del = p.coord -/ pe in
if del=P.zero
then p.right <- Curl (t,1.)
else p.right <- Given (t,n_arg del)
| _ -> ());
(*Format.printf "@[remove : p = @[%a@];@,q = @[%a@]@]@."
print_one_kpath p print_one_kpath q;*)
(* an auxiliary function *)
solve_choices p q n deltaxyk deltak psik;
if q!=h then aux q
in aux h)
let tension_of = function
| JTension (_,t1,t2,_) -> (t1,t2)
| JCurveNoInflex (_,_) -> (-1.,-1.)
| _ -> (1.,1.)
let direction t = function
| DNo -> Open t
| DVec p -> Given (t,n_arg p)
| DCurl f -> Curl (t,f)
let right_of_join p = function
| JLine -> Explicit p
| JControls (c,_) -> Explicit c
| JCurve (d,_) -> direction 1. d
| JCurveNoInflex (d,_) -> direction 1. d (*pas totalement correcte*)
| JTension (d,f,_,_) -> direction f d
let left_of_join p = function
| JLine -> Explicit p
| JControls (_,c) -> Explicit c
| JCurve (_,d) -> direction 1. d
| JCurveNoInflex (_,d) -> direction 1. d (*pas totalement correcte*)
| JTension (_,_,f,d) -> direction f d
let path_to_meta nknot l =
let rec aux aknot = function
| [] -> assert false
| [a] ->
let sa,sb,sc,sd = Spline.explode a in
nknot.left <- Explicit sc;
nknot.coord <- sd;
aknot.link <- nknot ;
aknot.right <- Explicit sb;
aknot.coord <- sa; ()
| a::l ->
let sa,sb,sc,_ = Spline.explode a in
let nknot = mk_kpath ~left:(Explicit sc) () in
aknot.link <- nknot;
aknot.right <- Explicit sb;
aknot.coord <- sa;
aux nknot l in
let aknot = mk_kpath ~left:Endpoint () in
aux aknot l;
aknot
let print_option f fmt = function
| None -> Format.fprintf fmt "None"
| Some e -> f fmt e
let kmeta_to_path ?cycle meta =
if info then
Format.printf "@[before (cycle:%a) : @[%a@]@]@."
(print_option print_joint) cycle print meta;
let rec to_knots aknot = function
| Start p ->
aknot.coord <- p;
aknot.left <- Endpoint;
aknot
| Cons (pa,join,p) ->
aknot.coord <- p;
aknot.left <- left_of_join p join;
let nknot = mk_kpath ~right:(right_of_join p join) ~link:aknot () in
to_knots nknot pa
| Start_Path pa -> path_to_meta aknot pa
| Append_Path (p1,join,p2) ->
let aknot2 = path_to_meta aknot p2 in
aknot2.left<- left_of_join aknot2.coord join;
let nknot =
mk_kpath ~right:(right_of_join aknot2.coord join) ~link:aknot2 () in
to_knots nknot p1 in
let lknots = mk_kpath ~right:Endpoint () in
let knots = to_knots lknots meta in
lknots.link <- knots;
(* Choose control points for the path and put the result into cur exp 891 *)
(* when nocycle *)
begin
match cycle with
|Some join ->
begin
lknots.right <- right_of_join knots.coord join;
knots.left <- left_of_join knots.coord join;
end
| None ->
begin
(match knots.right with
| Open t -> knots.right <- Curl (t,1.)
| _ -> ());
(match lknots.left with
| Open t -> lknots.left <- Curl (t,1.)
| _ -> ());
end
end;
if debug then
Format.printf "@[middle : @[%a@]@]@." print_kpath knots;
make_choices knots;
if debug then
Format.printf "@[after : @[%a@]@]@." print_kpath knots;
let rec aux = function
| {right = Endpoint} -> []
| {right = Explicit sb;coord = sa;
link={left = Explicit sc;coord = sd} as s} ->
Spline.create sa sb sc sd ::
(if s==knots then [] else (aux s))
| _ -> assert false in
aux knots
let kto_path ?cycle = function
| Start p -> S.Point p
| mp ->
let res = S.Path { S.pl = kmeta_to_path ?cycle mp;
cycle = cycle <> None} in
if info then
Format.printf "@[end : @[%a@]@]@." S.print res;
res
let rec to_path_simple = function
| Start p -> S.create_line p p
| Cons (pa,JLine,p) -> S.add_end_line (to_path_simple pa) p
| Cons (pa,JControls(c1,c2),p) -> S.add_end_spline (to_path_simple pa)
c1 c2 p
| Start_Path p -> S.Path {S.pl=p;cycle=false}
| Append_Path (p1,JControls(c1,c2),p2) ->
S.append (to_path_simple p1) c1 c2 (S.Path {S.pl=p2;cycle=false})
| (Cons(pa,JCurve _,p)) -> S.add_end_line (to_path_simple pa) p (* Faux*)
|p -> Format.printf "not implemented %a@." print p; not_implemented "to_path"
let knot p = p
let vec_direction p = DVec p
let curl_direction f = DCurl f
let no_direction = DNo
let equalize_dir = function
(* Faut-il égaliser l'un avec l'autre *et* l'autre avec l'un? *)
(*Put the pre-join direction information into node q 879 *)
| DNo, ((DVec p) as y) -> y,y
| c -> c
let start k = Start k
let line_joint = (*JLine but metafont defined -- as a macro for*)
JCurve(curl_direction 1.,curl_direction 1.)
let curve_joint dir1 dir2 = JCurve(dir1,dir2)
let curve_no_inflex_joint dir1 dir2 = JCurveNoInflex(dir1,dir2)
let tension_joint dir1 f1 f2 dir2 = JTension (dir1,f1,f2,dir2)
let controls_joint p1 p2 = JControls (p1,p2)
let concat p j k = Cons (p,j,k)
let rec append p j = function
| Start knot -> Cons (p,j,knot)
| Cons(p2,j2,k2) -> Cons(append p j p2,j2,k2)
| Start_Path p2 -> Append_Path(p,j,p2)
| Append_Path (p2,j2,p3) -> Append_Path(append p j p2,j2,p3)
let to_path p = kto_path p
let cycle j p = kto_path ~cycle:j p
let from_path = function
| S.Path p -> Start_Path p.S.pl
| S.Point p -> Start p
module Approx =
struct
let lineto = S.create_lines
let simple_join = curve_joint no_direction no_direction
let curve l =
let rec aux = function
| [] -> assert false
| [a] -> start (knot a)
| a::l -> concat (aux l) simple_join (knot a) in
aux (List.rev l)
let fullcircle_ l =
let l2 = l/.2. in
cycle simple_join
(curve [{x=l2;y=0.};{x=0.;y=l2};{x= -.l2;y=0.};{x=0.;y= -.l2}])
let fullcircle1 = lazy (fullcircle_ 1.)
let fullcircle = function
| 1. -> Lazy.force fullcircle1
| l -> fullcircle_ l
let halfcirle l =
(* 2. because fullcircle is defined with 4 points *)
S.subpath (fullcircle l) 0. 2.
let quartercircle l = S.subpath (fullcircle l) 0. 1.
let unitsquare l =
let p = {x=0.;y=0.} in
(S.close (S.create_lines [p;{x=l;y=0.};{x=l;y=l};{x=0.;y=l};p]))
end
mlpost-0.8.2/concrete/metapath_lib.mli 0000664 0000000 0000000 00000005121 13060465153 0017777 0 ustar 00root root 0000000 0000000 (**************************************************************************)
(* *)
(* Copyright (C) Johannes Kanig, Stephane Lescuyer *)
(* Jean-Christophe Filliatre, Romain Bardou and Francois Bobot *)
(* *)
(* This software is free software; you can redistribute it and/or *)
(* modify it under the terms of the GNU Library General Public *)
(* License version 2.1, with the special exception on linking *)
(* described in file LICENSE. *)
(* *)
(* This software is distributed in the hope that it will be useful, *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *)
(* *)
(**************************************************************************)
type point = Point_lib.t
type t
type joint
type knot
type direction
val print : Format.formatter -> t -> unit
val print_joint : Format.formatter -> joint -> unit
val print_dir : Format.formatter -> direction -> unit
val print_knot : Format.formatter -> knot -> unit
val knot : point -> knot
val vec_direction : point -> direction
val curl_direction : float -> direction
val no_direction : direction
val equalize_dir : direction * direction -> direction * direction
val line_joint : joint
val curve_joint : direction -> direction -> joint
val curve_no_inflex_joint : direction -> direction -> joint
val tension_joint : direction -> float -> float -> direction -> joint
val controls_joint : point -> point -> joint
val start : knot -> t
val concat : t -> joint -> knot -> t
val append : t -> joint -> t -> t
val cycle : joint -> t -> Spline_lib.path
val to_path : t -> Spline_lib.path
val from_path : Spline_lib.path -> t
module Approx :
sig
val lineto : point list -> Spline_lib.path
val fullcircle : float -> Spline_lib.path
(** fullcircle l is the circle of diameter l centered on (0, 0) *)
val halfcirle : float -> Spline_lib.path
(** halfcircle l is the upper half of a fullcircle of diameter l *)
val quartercircle : float -> Spline_lib.path
(** quartercircle l is the first quadrant of a circle of diameter l *)
val unitsquare : float -> Spline_lib.path
(** unitsquare l : the path (0,0)--(l,0)--(l,l)--(0,l)--cycle *)
end
mlpost-0.8.2/concrete/mps.ml 0000664 0000000 0000000 00000042140 13060465153 0015776 0 ustar 00root root 0000000 0000000 (**************************************************************************)
(* *)
(* Copyright (C) Johannes Kanig, Stephane Lescuyer *)
(* Jean-Christophe Filliatre, Romain Bardou and Francois Bobot *)
(* *)
(* This software is free software; you can redistribute it and/or *)
(* modify it under the terms of the GNU Library General Public *)
(* License version 2.1, with the special exception on linking *)
(* described in file LICENSE. *)
(* *)
(* This software is distributed in the hope that it will be useful, *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *)
(* *)
(**************************************************************************)
open Point_lib
open Matrix
module P = Picture_lib
module S = Spline_lib
open Dviinterp
open Concrete_types
let fprintf = Printf.fprintf
let conversion = 0.3937 *. 72.
let point_of_cm cm = conversion *. cm
let float fmt f =
(* PDF does not understand e notation, so we protect the printf which
uses %g in the cases where this would use e notation; we do not need that
much precision anyway*)
let a = abs_float f in
if a < 0.0001 then fprintf fmt "0"
else if a >= 1.e04 then fprintf fmt "%.4f" f
else Printf.fprintf fmt "%.4g" f
let rec list sep p fmt l =
match l with
| [] -> ()
| [x] -> p fmt x
| x::xs -> p fmt x; sep fmt; list sep p fmt xs
let option sep p fmt o =
match o with
| None -> ()
| Some x -> p fmt x ; sep fmt
let nothing _ = ()
let space fmt = fprintf fmt " "
type specials_env =
{ externalimages : (string * Matrix.t,int) Hashtbl.t;
colors : (P.color,int) Hashtbl.t;
count : int ref}
let new_specials_env () =
{externalimages = Hashtbl.create 7;
colors = Hashtbl.create 17;
count = ref 0}
module MPS = struct
type line_cap =
| ButtCap
| RoundCap
| SquareCap
type line_join =
| MiterJoin
| RoundJoin
| BevelJoin
let moveto_float fmt x y = fprintf fmt "%a %a moveto" float x float y
let lineto_float fmt x y = fprintf fmt "%a %a lineto" float x float y
let rlineto_float fmt x y = fprintf fmt "%a %a rlineto" float x float y
let lineto fmt p = lineto_float fmt p.x p.y
let moveto fmt p = moveto_float fmt p.x p.y
let rlineto fmt p = rlineto_float fmt p.x p.y
let lineto_floatp fmt (x,y) = lineto_float fmt x y
let curveto fmt p1 p2 p3 =
fprintf fmt "%a %a %a %a %a %a curveto"
float p1.x float p1.y float p2.x float p2.y float p3.x float p3.y
let close_path fmt = fprintf fmt "close_path"
let newpath fmt = fprintf fmt "newpath"
let stroke fmt = fprintf fmt "stroke"
let fill fmt = fprintf fmt "fill"
let showpage fmt = fprintf fmt "showpage"
let clip fmt = fprintf fmt "clip"
let gsave fmt = fprintf fmt "gsave"
let grestore fmt = fprintf fmt "grestore"
let setlinewidth fmt f =
(** strange treatment of linewidth of Metapost *)
fprintf fmt "0 %a dtransform truncate idtransform setlinewidth pop" float f
let setlinecap fmt c =
let i =
match c with
| ButtCap -> 0
| RoundCap -> 1
| SquareCap -> 2 in
fprintf fmt "%d setlinecap" i
let setlinejoin fmt j =
let i =
match j with
| MiterJoin -> 0
| RoundJoin -> 1
| BevelJoin -> 2 in
fprintf fmt "%d setlinejoin" i
let matrix fmt t =
fprintf fmt "[%a %a %a %a %a %a]"
float t.xx float t.yx float t.xy float t.yy float t.x0 float t.y0
let transform fmt t =
if t = Matrix.identity then () else fprintf fmt "%a concat" matrix t
let scolor_rgb fmt r g b =
fprintf fmt "%a %a %a setrgbcolor" float r float g float b
let scolor_cmyk fmt c m y k =
fprintf fmt "%a %a %a %a setcmykcolor" float c float m float y float k
let scolor_gray fmt c = fprintf fmt "%a setgray" float c
let scolor fmt c =
match c with
| Concrete_types.RGB (r,g,b) -> scolor_rgb fmt r g b
| Concrete_types.CMYK (c,m,y,k) -> scolor_cmyk fmt c m y k
| Concrete_types.Gray c -> scolor_gray fmt c
let color fmt c =
match c with
| Concrete_types.OPAQUE c -> scolor fmt c
| Concrete_types.TRANSPARENT _ ->
(* harvest take care of that case *)
assert false
let dvi_color fmt c =
match c with
| Dviinterp.RGB (r,g,b) -> scolor_rgb fmt r g b
| Dviinterp.CMYK (c,m,y,k) -> scolor_cmyk fmt c m y k
| Dviinterp.HSB _ -> assert false
| Dviinterp.Gray g -> scolor_gray fmt g
let dash fmt (offset,pattern) =
fprintf fmt "[%a ] %a setdash"
(list space float) pattern
float offset
let char_const fmt c = fprintf fmt "\\%03lo" c
let glyph fmt cl font =
fprintf fmt "(%a) %s %a fshow" (list nothing char_const) cl
(Fonts.tex_name font) float (Fonts.scale font conversion)
let glyphp fmt (cl, font) = glyph fmt cl font
let rectangle fmt p w h =
fprintf fmt "%t %a %a %a %a %t %t"
newpath
moveto p
lineto_floatp (p.x+.w, p.y)
lineto_floatp (p.x+.w, p.y+.h)
lineto_floatp (p.x, p.y+.h)
close_path
fill
let rectanglep fmt (p,w,h) = rectangle fmt p w h
end
let in_context fmt f = fprintf fmt "%t %t %t" MPS.gsave f MPS.grestore
let fill_rect fmt trans i x y w h =
let x = point_of_cm x and y = point_of_cm y
and w = point_of_cm w and h = point_of_cm h in
let p = { x = x ; y = y } in
in_context fmt (fun _ ->
fprintf fmt "%a %a %a"
MPS.transform trans
MPS.dvi_color i.Dviinterp.color
MPS.rectanglep (p,w,h)
)
let draw_char fmt trans text =
(* FIXME why do we need to negate y coordinates? *)
let (f1,f2) = text.tex_pos in
let f1 = point_of_cm f1 and f2 = point_of_cm f2 in
let p = { x = f1; y = -. f2 } in
in_context fmt (fun _ ->
fprintf fmt "%a %a %a %a"
MPS.transform trans
MPS.dvi_color text.Dviinterp.tex_info.Dviinterp.color
MPS.moveto p
MPS.glyphp (text.tex_string, text.tex_font)
)
(* FIXME why do we need to negate y coordinates? *)
let tex_cmd fmt trans c =
match c with
| Dviinterp.Fill_rect (i,x,y,w,h) ->
fill_rect fmt trans i x (-. y) w h
| Dviinterp.Draw_text text -> draw_char fmt trans text
| Dviinterp.Specials _ -> ()
| Dviinterp.Draw_text_type1 _ -> assert false
let draw_tex fmt t =
list space (fun fmt x -> tex_cmd fmt t.Gentex.trans x) fmt t.Gentex.tex
let curveto fmt s =
let sa, sb, sc, sd = Spline.explode s in
if sa = sb && sc = sd
then MPS.lineto fmt sd
else MPS.curveto fmt sb sc sd
let path =
let rec path fmt = function
| S.Path p ->
begin match p.S.pl with
| [] -> assert false
| (x::_) as l ->
fprintf fmt "%a %a"
MPS.moveto (Spline.left_point x)
(list space curveto) l
end ;
if p.S.cycle then begin fprintf fmt " %t" MPS.close_path end
| S.Point p ->
fprintf fmt "%a %a"
MPS.moveto p
MPS.rlineto p in
fun fmt p ->
fprintf fmt "%t %a"
MPS.newpath
path p
let pen fmt t =
(* FIXME do something better *)
(* for now assume that the pen is simply a scaled circle, so just grab the xx
* value of the matrix and use that as linewidth *)
MPS.setlinewidth fmt t.xx
let specials_signal = 0.123
let specials_division = 1000.
(** map real color to encoded color :
- identity for four first case
- encoding for transparency
- encoding specials rgb opaque color
*)
let add_color_se clr se =
match clr with
| None -> clr
| Some OPAQUE Gray _ -> clr
| Some OPAQUE CMYK _ -> clr
| Some OPAQUE RGB (r,_,_) when r <> specials_signal -> clr
| Some clr ->
let nb =
try
Hashtbl.find se.colors clr
with Not_found ->
incr se.count;
let nb = !(se.count) in
Hashtbl.add se.colors clr nb;
nb
in
let nb = (float_of_int nb) /. specials_division in
Some (OPAQUE (RGB (specials_signal,0.003,nb)))
let add_image_se =
let dumb_path = Spline_lib.create_lines
[Point_lib.zero;Point_lib.zero;
Point_lib.zero;Point_lib.zero] in
let dumb_path = Spline_lib.close dumb_path in
fun p se ->
let nb =
try
Hashtbl.find se.externalimages p
with Not_found ->
incr se.count;
let nb = !(se.count) in
Hashtbl.add se.externalimages p nb; nb in
(* 0.010? *)
let nb = (float_of_int nb) /. specials_division in
let c = Some (OPAQUE (RGB (specials_signal,0.019,nb))) in
P.Fill_path(dumb_path,c)
let rec harvest se = function
| P.Empty as p -> p
| P.OnTop l ->
let add acc e =
let p = harvest se e in
if p = P.Empty then acc else p::acc in
let l = List.fold_left add [] l in
if l = [] then P.Empty else P.OnTop (List.rev l)
| P.Stroke_path(p,c,d,e) -> P.Stroke_path(p,add_color_se c se,d,e)
| P.Fill_path (p,c) -> P.Fill_path (p,add_color_se c se)
| P.Tex _ as p -> p
| P.Transform (m,t) -> harvest se (P.apply_transform_cmds m t)
| P.Clip (com,p) ->
let com = harvest se com in
if com = P.Empty then com else P.Clip (com,p)
| P.ExternalImage (f,h,m) -> add_image_se (f,m) se
(*
For specials in mps
The specials are described at the bottom of the preamble
The first line describe the version, the special signal and the special_div
%%MetaPostSpecials: 2.0 123 1000
The next describe specials : length data special_number special_type
%%MetaPostSpecial: 7 1 0.5 1 0 0 1 3
Color cmyk : 7 (cmyk_counter) c m y k special_number 1
Color spot : 2
Color rgba : 7 mode_transparency value_transparency r g b special_number 3
Color cmyka : 8 mode_transparency value_transparency c m y k special_number 4
Color spota : 8 mode_transparency value_transparency ? ? ? ? special_number 5
In the text they appear as color :
special_signal (1 cmyk 2 spot 3 rgb) special_number
0.123 0.003 0.001 setrgbcolor
*)
let print_specials_color =
let pr_color fmt c =
match c with
| RGB (r,b,g) -> fprintf fmt "%f %f %f" r g b
| Gray g -> fprintf fmt "%f %f %f" g g g
| CMYK (c,m,y,k) -> fprintf fmt "%f %f %f %f" c m y k in
fun fmt cl id ->
let trans, c =
match cl with
| OPAQUE c -> 1., c
| TRANSPARENT (a,c) -> a, c in
let mode, special_type =
match c with
| RGB _ | Gray _ -> 7, 3
| CMYK _ -> 8, 4 in
fprintf fmt "%%%%MetaPostSpecial: ";
fprintf fmt "%i 1 %f %a %i %i\n" mode trans pr_color c id special_type
let print_specials_extimg fmt (f,m) id =
fprintf fmt
"%%%%MetaPostSpecial: 9 %f %f %f %f %f %f %s %i 10\n"
m.xx m.yx m.xy m.yy m.x0 m.y0 f id
let print_specials fmt cx =
let se = new_specials_env () in
let cx = harvest se cx in
if Hashtbl.length se.colors <> 0 || Hashtbl.length se.externalimages <> 0
then begin
fprintf fmt "%%%%MetaPostSpecials: 2.0 %i %i\n"
(int_of_float (specials_signal *. specials_division))
(int_of_float specials_division);
Hashtbl.iter (print_specials_color fmt) se.colors;
Hashtbl.iter (print_specials_extimg fmt) se.externalimages
end;
cx
let rec picture fmt p =
match p with
| P.Empty -> ()
| P.OnTop l -> list space picture fmt l
| P.Stroke_path(pa,clr,pe,da) ->
in_context fmt (fun _ ->
fprintf fmt "%a%a%a %a %t\n"
(option space MPS.color) clr
(option space MPS.dash) da
pen pe
path pa
MPS.stroke)
| P.Fill_path (p,clr)->
in_context fmt (fun _ ->
fprintf fmt "%a %a %t\n"
(option space MPS.color) clr
path p
MPS.fill)
| P.Tex t -> draw_tex fmt t
| P.Clip (com,p) ->
in_context fmt (fun _ ->
fprintf fmt "%a %t %a"
path p
MPS.clip
picture com
)
| P.Transform _
| P.ExternalImage _ -> assert false
module BitMap = struct
(* FIXME replace me by something more efficient *)
(* encode our bitmap as a string (array of chars) *)
type t = string
(* a char '0' corresponds to '0', a char '1' corresponds to '1' *)
let mk n = String.make n '0'
let set t n = t.[n] <- '1'
let get t n = t.[n]
let min t =
try String.index t '1' with Not_found -> assert false
let safe_sub_four s i =
(* if the string does not have 4 remaining chars, pad with zeros *)
let my_len = 4 in
let l = String.length s in
if i + my_len <= l then String.sub s i my_len
else
let buf = String.make my_len '0' in
for j = i to l - 1 do
buf.[j-i] <- s.[j]
done;
buf
let one_char t i =
match safe_sub_four t i with
| "0000" -> '0'
| "0001" -> '1'
| "0010" -> '2'
| "0011" -> '3'
| "0100" -> '4'
| "0101" -> '5'
| "0110" -> '6'
| "0111" -> '7'
| "1000" -> '8'
| "1001" -> '9'
| "1010" -> 'a'
| "1011" -> 'b'
| "1100" -> 'c'
| "1101" -> 'd'
| "1110" -> 'e'
| "1111" -> 'f'
| _ -> assert false
let chars t =
let b = Buffer.create 5 in
let rec aux k =
let c = one_char t k in
if c = '0' then Buffer.contents b
else begin
Buffer.add_char b c;
aux (k+4)
end in
let m = min t in
Printf.sprintf "%x:%s" m (aux m)
end
(* FIXME do better than comparing font names *)
module FontCmp = struct
type t = Fonts.t
let compare a b = String.compare (Fonts.tex_name a) (Fonts.tex_name b)
end
(* module FS = Set.Make(FontCmp) *)
module FM = Map.Make(FontCmp)
let max_char f =
(Fonts.metric f).Tfm.file_hdr.Tfm.ec
let fonts p =
let x = ref FM.empty in
Picture_lib.iter (fun p ->
match p with
| P.Tex g ->
List.iter (fun c ->
match c with
| Draw_text text ->
let f = text.tex_font in
let map =
try FM.find f !x
with Not_found ->
let map = BitMap.mk (max_char f) in
x := FM.add f map !x;
map in
List.iter (fun x ->
BitMap.set map (Int32.to_int x)) text.tex_string
| _ -> ()) g.Gentex.tex
| _ -> ()) p;
!x
(* Following the dvips manual, for example on
http://www.radicaleye.com/dvipsman/dvips.html#SEC34,
the Font line looks as follows:
%*Font: tfmname scaledbp designbp hex-start:hex-bitstring
Here is the meaning of each of these elements:
tfmname
The TeX TFM filename, e.g., `cmr10'. You can give the same tfmname on more
than one `%*Font' line; this is useful when the number of characters from
the font used needs a longer hex-bitstring (see item below) than
conveniently fits on one line.
scaledbp
The size at which you are using the font, in PostScript points (TeX big
points). 72bp = 72.27pt = 1in.
designbp
The designsize of the font, again in PostScript points. This should match
the value in the TFM file tfmname. Thus, for `cmr10', it should be
`9.96265'.
hex-start
The character code of the first character used from the font, specified as
two ASCII hexadecimal characters, e.g., `4b' or `4B' for `K'.
hex-bitstring
An arbitrary number of ASCII hexadecimal digits specifying which characters
following (and including) hex-start are used. This is treated as a bitmap.
For example, if your figure used the single letter `K', you would use
`4b:8' for hex-start and hex-bitstring. If it used `KLMNP', you would use
`4b:f4'.
*)
let fontdecl fmt f map =
let n = Fonts.tex_name f in
let d = Fonts.design_size f in
let r = point_of_cm (Fonts.ratio_cm f) in
let magic_string = BitMap.chars map in
fprintf fmt "%%*Font: %s %f %f %s\n" n d r magic_string
let draw fmt x =
let {x = minx; y = miny},{x = maxx; y = maxy} = Picture_lib.bounding_box x in
let minxt, minyt, maxxt, maxyt =
floor minx, floor miny, ceil maxx, ceil maxy in
fprintf fmt "%%!PS\n";
fprintf fmt "%%%%BoundingBox: %f %f %f %f\n" minxt minyt maxxt maxyt;
fprintf fmt "%%%%HiResBoundingBox: %f %f %f %f\n" minx miny maxx maxy;
fprintf fmt "%%%%Creator: Mlpost %s\n" Version.version;
(** metapost add a creation date but it breaks determinism *)
(* fprintf fmt "%%%%CreationDate: %s\n" (Misc.date_string ()); *)
fprintf fmt "%%%%Pages: 1\n";
FM.iter (fontdecl fmt) (fonts x);
fprintf fmt "%%%%BeginProlog\n";
fprintf fmt "%%%%EndProlog\n";
fprintf fmt "%%%%Page: 1 1\n";
let cx = print_specials fmt (P.content x) in
fprintf fmt "%a %a %a %a %t"
MPS.setlinewidth (P.default_line_size /.2.)
MPS.setlinecap MPS.RoundCap
MPS.setlinejoin MPS.RoundJoin
picture cx
MPS.showpage;
fprintf fmt "\n%%%%EOF\n"
let generate_one fn fig =
File.write_to fn (fun fmt ->
let fig = Compute.commandpic fig in
(* Format.printf "picturelib code: \n %a@." P.Print.pic fig; *)
draw fmt fig);
fn
let mps figl =
List.map (fun (fn,fig) ->
let fn = File.mk fn "mps" in
(* Format.printf "metapost code:\n %a@."Print.commandpic fig; *)
generate_one fn fig) figl
let dump () = ignore (mps (Defaults.emited ()))
let generate figs = ignore (mps figs)
mlpost-0.8.2/concrete/mps.mli 0000664 0000000 0000000 00000002375 13060465153 0016155 0 ustar 00root root 0000000 0000000 (**************************************************************************)
(* *)
(* Copyright (C) Johannes Kanig, Stephane Lescuyer *)
(* Jean-Christophe Filliatre, Romain Bardou and Francois Bobot *)
(* *)
(* This software is free software; you can redistribute it and/or *)
(* modify it under the terms of the GNU Library General Public *)
(* License version 2.1, with the special exception on linking *)
(* described in file LICENSE. *)
(* *)
(* This software is distributed in the hope that it will be useful, *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *)
(* *)
(**************************************************************************)
val draw : out_channel -> Picture_lib.t -> unit
val dump: unit -> unit
val generate : (string * Command.t) list -> unit
mlpost-0.8.2/concrete/myocamlbuild.ml 0000664 0000000 0000000 00000010771 13060465153 0017665 0 ustar 00root root 0000000 0000000 (**************************************************************************)
(* *)
(* Copyright (C) Johannes Kanig, Stephane Lescuyer *)
(* Jean-Christophe Filliatre, Romain Bardou and Francois Bobot *)
(* *)
(* This software is free software; you can redistribute it and/or *)
(* modify it under the terms of the GNU Library General Public *)
(* License version 2.1, with the special exception on linking *)
(* described in file LICENSE. *)
(* *)
(* This software is distributed in the hope that it will be useful, *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *)
(* *)
(**************************************************************************)
open Ocamlbuild_plugin
(* open Command -- no longer needed for OCaml >= 3.10.2 *)
(* these functions are not really officially exported *)
let run_and_read = Ocamlbuild_pack.My_unix.run_and_read
let blank_sep_strings = Ocamlbuild_pack.Lexers.blank_sep_strings
let split s ch =
let x = ref [] in
let rec go s =
let pos = String.index s ch in
x := (String.before s pos)::!x;
go (String.after s (pos + 1))
in
try
go s
with Not_found -> !x
let split_nl s = split s '\n'
let before_space s =
try
String.before s (String.index s ' ')
with Not_found -> s
(* this lists all supported packages *)
let find_packages () =
List.map before_space (split_nl & run_and_read "ocamlfind list")
(* this is supposed to list available syntaxes, but I don't know how to do it. *)
let find_syntaxes () = ["camlp4o"; "camlp4r"; "bitstring.syntax"]
(* ocamlfind command *)
let ocamlfind x = S[A"ocamlfind"; x]
let _ = dispatch begin function
| Before_options ->
(* by using Before_options one let command line options have an higher priority *)
(* on the contrary using After_options will guarantee to have the higher priority *)
(* override default commands by ocamlfind ones *)
Options.ocamlc := ocamlfind & A"ocamlc";
Options.ocamlopt := ocamlfind & A"ocamlopt";
Options.ocamldep := ocamlfind & A"ocamldep";
Options.ocamldoc := ocamlfind & A"ocamldoc";
Options.ocamlmktop := ocamlfind & A"ocamlmktop"
| After_rules ->
(* When one link an OCaml library/binary/package, one should use -linkpkg *)
flag ["ocaml"; "link"] & A"-linkpkg";
(* For each ocamlfind package one inject the -package option when
* compiling, computing dependencies, generating documentation and
* linking. *)
List.iter begin fun pkg ->
flag ["ocaml"; "compile"; "pkg_"^pkg] & S[A"-package"; A pkg];
flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S[A"-package"; A pkg];
flag ["ocaml"; "doc"; "pkg_"^pkg] & S[A"-package"; A pkg];
flag ["ocaml"; "link"; "pkg_"^pkg] & S[A"-package"; A pkg];
end (find_packages ());
(* Like -package but for extensions syntax. Morover -syntax is useless
* when linking. *)
List.iter begin fun syntax ->
flag ["ocaml"; "compile"; "syntax_"^syntax] & S[A"-syntax"; A syntax];
flag ["ocaml"; "ocamldep"; "syntax_"^syntax] & S[A"-syntax"; A syntax];
flag ["ocaml"; "doc"; "syntax_"^syntax] & S[A"-syntax"; A syntax];
end (find_syntaxes ());
(* The default "thread" tag is not compatible with ocamlfind.
Indeed, the default rules add the "threads.cma" or "threads.cmxa"
options when using this tag. When using the "-linkpkg" option with
ocamlfind, this module will then be added twice on the command line.
To solve this, one approach is to add the "-thread" option when using
the "threads" package using the previous plugin.
*)
flag ["ocaml"; "pkg_threads"; "compile"] (S[A "-thread"]);
flag ["ocaml"; "pkg_threads"; "link"] (S[A "-thread"])
| _ -> ()
end
mlpost-0.8.2/concrete/picture_lib.ml 0000664 0000000 0000000 00000020227 13060465153 0017502 0 ustar 00root root 0000000 0000000 (**************************************************************************)
(* *)
(* Copyright (C) Johannes Kanig, Stephane Lescuyer *)
(* Jean-Christophe Filliatre, Romain Bardou and Francois Bobot *)
(* *)
(* This software is free software; you can redistribute it and/or *)
(* modify it under the terms of the GNU Library General Public *)
(* License version 2.1, with the special exception on linking *)
(* described in file LICENSE. *)
(* *)
(* This software is distributed in the hope that it will be useful, *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *)
(* *)
(**************************************************************************)
let diameter_of_a_dot = 3.
let default_line_size = 1.
module BoundingBox : sig
type pen = Spline_lib.path
type t
(** The type of the approximation *)
val iter : (Spline.t -> unit) -> t -> unit
val empty : t
val create : ?base:pen -> Spline_lib.path -> t
val of_path : ?base:pen -> Spline_lib.path -> t
val union : t -> t -> t
val transform : Matrix.t -> t -> t
val bounding_box : t -> Point_lib.t * Point_lib.t
val of_bounding_box : Point_lib.t * Point_lib.t -> t
end =
struct
(* A rendre plus performant ou pas*)
(* le point correspond à un écart à prendre autour de la bounding box *)
module S = Spline_lib
module P = Point_lib
type pen = S.path
type t = (Spline.t list * pen) list
let iter f l = List.iter (fun (e,_) -> List.iter (fun s -> f s) e) l
let empty = []
let create ?(base= S.Point P.zero) = function
| S.Path p -> [p.S.pl,base]
| S.Point p ->
let x =
match S.of_bounding_box (p,p) with
| S.Path p -> p.S.pl
| S.Point _ -> assert false
in
[x, base]
let of_path = create
let union x y = List.rev_append x y
let transform t x =
List.map (fun (x,f) ->
List.map (Spline.transform t) x,
S.transform (Matrix.remove_translation t) f) x
open P
open P.Infix
let bounding_box sl =
let (x_min,y_min,x_max,y_max) =
P.list_min_max_float (fun (e,f) ->
let (x_min,y_min,x_max,y_max)=
P.list_min_max_float Spline.precise_bounding_box e in
let pen_min,pen_max = S.bounding_box f in
let p1,p2 =
{x=x_min;y=y_min}+/pen_min,{x=x_max;y=y_max}+/pen_max in
(p1.x,p1.y,p2.x,p2.y)) sl in
{x=x_min;y=y_min},{x=x_max;y=y_max}
let of_bounding_box l = create (S.of_bounding_box l)
end
module MP = Metapath_lib
open Types
module P = Point_lib
module S = BoundingBox
type transform = Matrix.t
type num = float
type dash = float * num list
type pen = transform
type color = Concrete_types.color
type path = Spline_lib.path
type id = int
type interactive =
| IntEmpty
| IntTransform of interactive * transform
| IntClip of interactive * path
| IntOnTop of interactive * interactive
| Inter of path * id
type commands =
| Empty
| Transform of transform * commands
| OnTop of commands list
| Tex of Gentex.t
| Stroke_path of path * color option * pen * dash option
| Fill_path of path * color option
| Clip of commands * path
| ExternalImage of string * float * transform
and t = { fcl : commands;
fb : BoundingBox.t;
fi : interactive}
let content x = x.fcl
let empty = { fcl = Empty; fb = S.empty ; fi = IntEmpty }
let tex t = {fcl = Tex t;
fb = S.of_bounding_box (Gentex.bounding_box t);
fi = IntEmpty}
let fill_path p c = {fcl = Fill_path (p,c);
fb = S.of_path p;
fi = IntEmpty}
let base_of_pen pen =
Spline_lib.transform pen (MP.Approx.fullcircle default_line_size)
let stroke_path p c pen d =
{ fcl= Stroke_path (p,c,pen,d);
fb = S.of_path ~base:(base_of_pen pen) p;
fi = IntEmpty}
let draw_point p =
stroke_path (Spline_lib.create_point p) None
(Matrix.scale diameter_of_a_dot) None
let clip p path = {fcl= Clip (p.fcl,path);
fb = S.of_path path;
(* la bounding box d'un clip est la bounding_box du chemin fermé*)
fi = IntClip (p.fi,path)}
let externalimage_dimension filename : float * float =
let inch = Unix.open_process_in
(Format.sprintf "identify -format \"%%h\\n%%w\" \"%s\"" filename) in
try let h = float_of_string (input_line inch) in
let w = float_of_string (input_line inch) in (h,w)
with End_of_file | Failure "float_of_string" ->
invalid_arg (Format.sprintf "Unknown external image %s" filename)
let external_image filename spec =
let fh,fw = externalimage_dimension filename in
let height,width =
begin
match spec with
| `Exact (h,w) -> (h,w)
| `None -> (fh,fw)
| `Height h -> h,(fw/.fh)*.h
| `Width w -> (fh/.fw)*.w,w
| `Inside (h,w) ->
let w = min (h*.(fw/.fh)) w in
(fh/.fw)*.w,w
end in
(* TODO : width/.fw pour cairo width pour mps *)
let m = Matrix.multiply (Matrix.xscaled width)
(Matrix.yscaled height) in
{fcl = ExternalImage (filename,height,m);
fb = S.of_bounding_box (P.zero,{P.x=width;y=height});
fi = IntEmpty}
let interactive path id = {fcl = Empty;
fb = S.empty;
fi = Inter (path,id)}
let is_empty t = t.fcl = Empty
let on_top t1 t2 =
if is_empty t1 then t2
else if is_empty t2 then t1
else
{ fcl = OnTop [t1.fcl;t2.fcl];
fb = S.union (t1.fb) (t2.fb);
fi = IntOnTop (t1.fi,t2.fi) }
let transform m t = {fcl = Transform (m,t.fcl);
fb = S.transform m t.fb;
fi = IntTransform (t.fi,m)}
let shift t w h = transform (Matrix.xy_translation w h) t
let bounding_box t = S.bounding_box t.fb
let baseline p = match p.fcl with
| Tex tex -> Gentex.get_bases_pt tex
| _ -> []
let apply_transform_cmds t =
let rec aux pic =
match pic with
| Empty -> Empty
| OnTop l -> OnTop (List.map aux l)
| Fill_path (p,c) -> Fill_path (path p,c)
| Stroke_path (pa,c,pe,d) ->
Stroke_path (path pa, c, pe, d)
| Clip (cmds, p) -> Clip (aux cmds, path p)
| Tex g -> Tex { g with Gentex.trans = Matrix.multiply t g.Gentex.trans }
| ExternalImage (f,h,m) -> ExternalImage (f,h,Matrix.multiply t m)
| Transform (t', l) -> Transform (Matrix.multiply t' t, l)
and path p = Spline_lib.transform t p in
aux
let iter f t =
let rec aux p =
f p;
match p with
| Empty | Fill_path _ | Stroke_path _ | ExternalImage _ | Tex _ -> ()
| OnTop l -> List.iter aux l
| Clip (c,_) -> aux c
| Transform (_,l) -> aux l in
aux (content t)
let apply_transform t p =
{ p with fcl = apply_transform_cmds t p.fcl;
fb = BoundingBox.transform t p.fb;
}
module Dash =
struct
type t = float * float list
type input_dash =
| On of float
| Off of float
let shifted f (x,d) = (x+.f,d)
let line = 0., [3.; 3. ]
let dots = 0., [0.; 5.]
let rec on acc = function
| [] -> [acc]
| On f::l -> on (f +. acc) l
| Off f::l -> acc::(off f l)
and off acc = function
| [] -> [acc]
| On f::l -> acc::(on f l)
| Off f::l -> off (f +. acc) l
and to_dash = function
| [] -> []
| On f::l -> on f l
| Off f::l -> 0. :: (off f l)
let pattern l =
0., to_dash l
let scale f (x,l) =
x, List.map (fun z -> f *. z) l
end
module Print = struct
(* debug printing *)
open Format
let rec command fmt c =
match c with
| Empty -> pp_print_string fmt "empty"
| Stroke_path (p,_,_,_) -> Spline_lib.print fmt p
| Tex g -> Gentex.deb_print fmt g
| OnTop cl -> Misc.print_list Misc.newline command fmt cl
(*
| Transform of transform * commands
| Fill_path of path * color option
| Clip of commands * path
| ExternalImage of string * float * float
*)
| _ -> assert false
let pic fmt p = command fmt p.fcl
end
mlpost-0.8.2/concrete/picture_lib.mli 0000664 0000000 0000000 00000005564 13060465153 0017662 0 ustar 00root root 0000000 0000000 (**************************************************************************)
(* *)
(* Copyright (C) Johannes Kanig, Stephane Lescuyer *)
(* Jean-Christophe Filliatre, Romain Bardou and Francois Bobot *)
(* *)
(* This software is free software; you can redistribute it and/or *)
(* modify it under the terms of the GNU Library General Public *)
(* License version 2.1, with the special exception on linking *)
(* described in file LICENSE. *)
(* *)
(* This software is distributed in the hope that it will be useful, *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *)
(* *)
(**************************************************************************)
type transform = Matrix.t
type num = float
type dash = float * num list
type pen = transform
type color = Concrete_types.color
type path = Spline_lib.path
type interactive
type commands =
| Empty
| Transform of transform * commands
| OnTop of commands list
| Tex of Gentex.t
| Stroke_path of path * color option * pen * dash option
| Fill_path of path * color option
| Clip of commands * path
| ExternalImage of string * float * transform
(* filename, height, transform *)
type t
type id = int
val content : t -> commands
val tex : Gentex.t -> t
val fill_path : path -> color option -> t
val stroke_path : path -> color option -> pen -> dash option -> t
val draw_point : Point_lib.t -> t
val default_line_size : float
val clip : t -> path -> t
val external_image : string ->
[< `Exact of float * float
| `Height of float
| `Inside of float * float
| `None
| `Width of float ] -> t
val interactive : Spline_lib.path -> id -> t
val on_top : t -> t -> t
val empty : t
val transform : Matrix.t -> t -> t
val shift : t -> float -> float -> t
val apply_transform : Matrix.t -> t -> t
val apply_transform_cmds : Matrix.t -> commands -> commands
val iter : (commands -> unit) -> t -> unit
val bounding_box : t -> Point_lib.t * Point_lib.t
(* lower left and upper right point *)
(* Return the empty list if the picture is not directly a Tex *)
val baseline : t -> float list
module Dash :
sig
type t = dash
type input_dash =
| On of float
| Off of float
val shifted : float -> t -> t
val line : t
val dots : t
val pattern : input_dash list -> t
val scale : float -> t -> t
end
module Print : sig
val command : Format.formatter -> commands -> unit
val pic : Format.formatter -> t -> unit
end
mlpost-0.8.2/concrete/point_lib.ml 0000664 0000000 0000000 00000006157 13060465153 0017166 0 ustar 00root root 0000000 0000000 (**************************************************************************)
(* *)
(* Copyright (C) Johannes Kanig, Stephane Lescuyer *)
(* Jean-Christophe Filliatre, Romain Bardou and Francois Bobot *)
(* *)
(* This software is free software; you can redistribute it and/or *)
(* modify it under the terms of the GNU Library General Public *)
(* License version 2.1, with the special exception on linking *)
(* described in file LICENSE. *)
(* *)
(* This software is distributed in the hope that it will be useful, *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *)
(* *)
(**************************************************************************)
open Ctypes
type t = point = { x : float; y : float }
let zero = { x = 0. ; y = 0. }
let add a b = {x = a.x+.b.x; y = a.y+.b.y}
let sub a b = {x = a.x-.b.x; y = a.y-.b.y}
let opp a = {x = -.a.x; y = -.a.y}
let mult c a = {x = a.x*.c; y = a.y*.c}
let div a c = {x = a.x/.c; y = a.y/.c}
let transform m p =
{ x = m.xx *. p.x +. m.xy *. p.y +. m.x0;
y = m.yx *. p.x +. m.yy *. p.y +. m.y0;
}
(* copied here from matrix.ml to avoid dependency *)
let init_rotate a =
let s = sin a in
let c = cos a in
{ xx = c; yx = s; xy = -.s; yy = c; x0 = 0.; y0 = 0. }
let rotated f = transform (init_rotate f)
let swapmx {x=x;y=y} = {x=y;y= -.x}
let swapmy {x=x;y=y} = {x= -.y;y=x}
module Infix =
struct
let (+/) = add
let (-/) = sub
let ( */) = mult
let ( //) = div
end
open Infix
let segment f p1 p2 = (1.-.f) */ p1 +/ f */ p2
let middle = segment 0.5
let print fmt x = Format.fprintf fmt "(%f,%f)" x.x x.y
let norm2 p : float = p.x*.p.x+.p.y*.p.y
let norm p = sqrt (norm2 p)
let dist2 a b = norm2 (a -/ b)
let dist a b = sqrt (dist2 a b)
let list_min_max f =
List.fold_left (fun ({x=x_min;y=y_min},{x=x_max;y=y_max}) s ->
let ({x=sx_min;y=sy_min},{x=sx_max;y=sy_max}) = f s in
{x=min x_min sx_min;y=min y_min sy_min},
{x=max x_max sx_max;y=max y_max sy_max})
({x=infinity;y=infinity},{x=neg_infinity;y=neg_infinity})
let list_min_max_float f p =
List.fold_left (fun (x_min,y_min,x_max,y_max) s ->
let (sx_min,sy_min,sx_max,sy_max) = f s in
(min x_min sx_min,min y_min sy_min,
max x_max sx_max,max y_max sy_max))
(infinity,infinity,neg_infinity,neg_infinity) p
let sign f =
if f = 0. then 0.
else if f < 0. then -1. else 1.
let sign { x=x; y = y} = { x = sign x; y = sign y}
let norm_infinity default f =
if f = infinity || f = neg_infinity then default
else f
let norm_infinity {x=xdef;y=ydef} {x=x;y=y} =
{x= norm_infinity xdef x;y= norm_infinity ydef y}
mlpost-0.8.2/concrete/point_lib.mli 0000664 0000000 0000000 00000003745 13060465153 0017337 0 ustar 00root root 0000000 0000000 (**************************************************************************)
(* *)
(* Copyright (C) Johannes Kanig, Stephane Lescuyer *)
(* Jean-Christophe Filliatre, Romain Bardou and Francois Bobot *)
(* *)
(* This software is free software; you can redistribute it and/or *)
(* modify it under the terms of the GNU Library General Public *)
(* License version 2.1, with the special exception on linking *)
(* described in file LICENSE. *)
(* *)
(* This software is distributed in the hope that it will be useful, *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *)
(* *)
(**************************************************************************)
type t = Ctypes.point =
{ x : float; y : float }
val zero : t
val add : t -> t -> t
val sub : t -> t -> t
val mult : float -> t -> t
val div : t -> float -> t
val rotated : float -> t -> t
val transform : Ctypes.matrix -> t -> t
val swapmx : t -> t
val swapmy : t -> t
val sign : t -> t
val middle : t -> t -> t
val norm : t -> float
val norm2 : t -> float
val dist : t -> t -> float
val dist2 : t -> t -> float
val list_min_max : ('a -> t * t) -> 'a list -> t * t
val list_min_max_float :
('a -> float * float * float * float) -> 'a list ->
float * float * float * float
val opp : t -> t
val print : Format.formatter -> t -> unit
module Infix :
sig
val (+/) : t -> t -> t
val (-/) : t -> t -> t
val ( */) : float -> t -> t
val ( //) : t -> float -> t
end
val norm_infinity : t -> t -> t
val segment : float -> t -> t -> t
mlpost-0.8.2/concrete/spline.ml 0000664 0000000 0000000 00000025705 13060465153 0016501 0 ustar 00root root 0000000 0000000 open Point_lib
open Point_lib.Infix
module P = Point_lib
type point = Ctypes.point
type abscissa = float
type t =
{
sa : point;
sb : point;
sc : point;
sd : point;
}
let inter_depth = ref 15
let debug = false
let pt_f fmt p = Format.fprintf fmt "{@[ %.20g,@ %.20g @]}" p.x p.y
let print fmt pt =
Format.fprintf fmt "@[{ %a,@ %a,@ %a,@ %a }@]@."
pt_f pt.sa pt_f pt.sb pt_f pt.sc pt_f pt.sd
let create a b c d =
{
sa = a; sb = b;
sc = c; sd = d;
}
let create_with_offset offs a b c d =
create a b c d
let explode s = s.sa, s.sb, s.sc, s.sd
let reverse conv {sa=sa;sb=sb;sc=sc;sd=sd} =
{sa=sd;sb=sc;sc=sb;sd=sa}
let right_control_point t = t.sc
let right_point t = t.sd
let left_point t = t.sa
let left_control_point t = t.sb
let cubic a b c d t =
t*.(t*.(t*.(d +. 3.*.(b -. c) -. a) +. 3. *. (c -. (2. *. b) +. a))
+. 3. *. (b -. a)) +. a
(* ((t^3)*(d - (3*c) + (3*b) - a)) + (3*(t^2)*(c - (2*b) + a)) +
* (3*t*(b - a)) + a*)
(* d *. (t**3.) +. 3. *. c *. (t**2.) *. (1. -. t) +. 3. *. b *. (t**1.)
* *.(1. -. t)**2. +. a *. (1. -. t)**3.*)
let point_of s t =
{ x=cubic s.sa.x s.sb.x s.sc.x s.sd.x t;
y=cubic s.sa.y s.sb.y s.sc.y s.sd.y t;}
let point_of_s s t =
assert ( 0. <= t && t <= 1.);
point_of s t
let direction s t =
(* An expression as polynomial:
short but lots of point operations
(d-3*c+3*b-a)*t^2+(2*c-4*b+2*a)*t+b-a *)
(*
t */ (t */ (s.sd -/ 3. */ (s.sc +/ s.sb) -/ s.sa) +/
2. */ (s.sc +/ s.sa -/ 2. */ s.sb)) +/ s.sb -/ s.sa
*)
(* This expression is longer, but has less operations on points: *)
(t**2.) */ s.sd +/ (((2. *. t) -. (3. *. (t**2.)))) */ s.sc +/
((1. -. (4. *. t)+.(3. *. (t**2.)))) */ s.sb +/ (-.((1. -. t)**2.)) */ s.sa
let extremum a b c d =
let eqa = d -. a +. (3.*.(b -. c)) in
let eqb = 2.*.(c +. a -. (2.*.b)) in
let eqc = b -. a in
(*Format.printf "eqa : %f; eqb : %f; eqc : %f@." eqa eqb eqc;*)
let test s l = if s>=0. && s<=1. then s::l else l in
if eqa = 0. then if eqb = 0. then []
else test (-. eqc /. eqb) []
else
(*let sol delta = (delta -. (2.*.b) +. a +. c)/.
(a -. d +. (3.*.(c -. b))) in*)
(*let delta = ((b*.b) -. (c*.(b +. a -. c)) +. (d*.(a -. b))) in*)
let sol delta = (delta +. eqb) /. (-.2.*.eqa) in
let delta = (eqb*.eqb) -. (4.*.eqa*.eqc) in
(*Format.printf "delta2 : %f; delta : %f@." delta2 delta;*)
match compare delta 0. with
| x when x<0 -> []
| 0 -> test (sol 0.) []
| _ ->
let delta = delta**0.5 in
test (sol delta) (test (sol (-.delta)) [])
let remarkable a b c d =
let res = 0.::1.::(extremum a b c d) in
(*Format.printf "remarquable : %a@."
(fun fmt -> List.iter (Format.printf "%f;")) res;*)
res
let apply_x f s = f s.sa.x s.sb.x s.sc.x s.sd.x
let apply_y f s = f s.sa.y s.sb.y s.sc.y s.sd.y
let apply4 f s = f s.sa s.sb s.sc s.sd
let f4 f a b c d = f (f a b) (f c d)
let bounding_box s =
let x_max = apply_x (f4 Pervasives.max) s in
let y_max = apply_y (f4 Pervasives.max) s in
let x_min = apply_x (f4 Pervasives.min) s in
let y_min = apply_y (f4 Pervasives.min) s in
x_min,y_min,x_max,y_max
let precise_bounding_box s =
(*Format.printf "precise : %a@." print_spline s;*)
let x_remarq = List.map (apply_x cubic s) (apply_x remarkable s) in
let y_remarq = List.map (apply_y cubic s) (apply_y remarkable s) in
let x_max = List.fold_left Pervasives.max neg_infinity x_remarq in
let y_max = List.fold_left Pervasives.max neg_infinity y_remarq in
let x_min = List.fold_left Pervasives.min infinity x_remarq in
let y_min = List.fold_left Pervasives.min infinity y_remarq in
x_min,y_min,x_max,y_max
let bisect a =
let b = a in
(*D\leftarrow (C+D)/2*)
let b = {b with sd = middle b.sd b.sc} in
(*C\leftarrow (B+C)/2, D\leftarrow (C+D)/2*)
let b = {b with sc = middle b.sc b.sb} in
let b = {b with sd = middle b.sd b.sc} in
(*B\leftarrow (A+B)/2, C\leftarrow (B+C)/2, D\leftarrow(C+D)/2*)
let b = {b with sb = middle b.sb b.sa} in
let b = {b with sc = middle b.sc b.sb} in
let b = {b with sd = middle b.sd b.sc} in
let c = a in
let c = {c with sa = middle c.sa c.sb} in
let c = {c with sb = middle c.sb c.sc} in
let c = {c with sa = middle c.sa c.sb} in
let c = {c with sc = middle c.sc c.sd} in
let c = {c with sb = middle c.sb c.sc} in
let c = {c with sa = middle c.sa c.sb} in
b,c
let test_in amin amax bmin bmax =
(amin <= bmax && bmin <= amax)
let is_intersect a b =
let (ax_min,ay_min,ax_max,ay_max) = bounding_box a in
let (bx_min,by_min,bx_max,by_max) = bounding_box b in
test_in ax_min ax_max bx_min bx_max &&
test_in ay_min ay_max by_min by_max
let is_intersect_precise a b =
let (ax_min,ay_min,ax_max,ay_max) = precise_bounding_box a in
let (bx_min,by_min,bx_max,by_max) = precise_bounding_box b in
test_in ax_min ax_max bx_min bx_max &&
test_in ay_min ay_max by_min by_max
let intersect_fold f acc a b =
let rec aux acc a b t1 t2 dt = function
| 0 ->
if is_intersect a b then f (t1 + (dt/2), t2 + (dt/2)) acc
else acc
| n ->
if is_intersect a b then
let n = n - 1 and dt = dt / 2 in
let a1,a2 = bisect a and b1,b2 = bisect b in
let acc = aux acc a1 b1 t1 t2 dt n in
let acc = aux acc a1 b2 t1 (t2+dt) dt n in
let acc = aux acc a2 b1 (t1+dt) t2 dt n in
let acc = aux acc a2 b2 (t1+dt) (t2+dt) dt n in
acc
else acc
in
let nmax = int_of_float (2.**(float_of_int (!inter_depth+1))) in
aux acc a b 0 0 nmax !inter_depth
exception Found of int*int
let one_intersection a b =
let nmax = 2.**(float_of_int (!inter_depth+1)) in
let f_from_i x = (float_of_int x)*.(1./.nmax) in
try
intersect_fold (fun (x,y) () -> raise (Found (x,y))) () a b;
raise Not_found
with
Found (t1,t2) -> f_from_i t1, f_from_i t2
module UF = Unionfind
let intersection a b =
if a=b then [] else
let rem_noise delta mdelta = function
| [] -> []
| noisy ->
let uf = UF.init noisy in
let link sel msel =
let sorted =
List.fast_sort (fun x y -> compare (sel x) (sel y)) noisy in
let rec pass bef = function
|[] -> ()
|e::l ->
if sel bef - sel e <= delta then
(if abs (msel e - msel bef) <= mdelta
then UF.union e bef uf;
pass bef l)
else ()
in
ignore (List.fold_left (fun acc bef -> pass bef acc;bef::acc)
[] sorted)
in
link fst snd; link snd fst;
UF.fold_classes (fun x acc -> x :: acc) [] uf
in
let nmax = 2.**(float_of_int (!inter_depth+1)) in
let l = intersect_fold (fun x acc -> x::acc) [] a b in
if debug then
Format.printf "@[%a@]@."
(fun fmt ->
List.iter (fun (f1,f2) -> Format.fprintf fmt "%i,%i" f1 f2)
) l;
let l = rem_noise (2 * !inter_depth) (16 * !inter_depth) l in
let f_from_i x = x *. (1./.nmax) in
let res = List.rev_map (fun (x,y) -> (f_from_i x,f_from_i y)) l in
if debug then
Format.printf "@[%a@]@." (fun fmt -> List.iter (pt_f fmt))
(List.map (fun (t1,t2) ->
(point_of a t1) -/ (point_of b t2)) res);
res
type split =
| Min
| Max
| InBetween of t * t
let split s t =
assert (0. <= t && t <= 1.);
if t = 1. then Max
else if t = 0. then Min
else
let t0 = (*_01_of_s s*) t in
let _1t0 = 1.-.t0 in
let b1 = t0 */ s.sb +/ _1t0 */ s.sa in
let c1 =
(t0 *. t0) */ s.sc +/ (2. *. t0 *. _1t0) */ s.sb
+/ (_1t0 *. _1t0) */ s.sa
in
let d1 = point_of s t0 in
let a2 = d1 in
let c2 = _1t0 */ s.sc +/ t0 */ s.sd in
let b2 =
(_1t0*._1t0) */ s.sb +/ (2.*._1t0*.t0) */ s.sc +/ (t0*.t0) */ s.sd in
InBetween ({s with sb = b1;sd = d1;sc = c1},
{s with sa = a2;sb = b2;sc = c2})
let norm2 a b = a*.a +. b*.b
let is_possible (axmin,aymin,axmax,aymax) (bxmin,bymin,bxmax,bymax) =
match axmin > bxmax, aymin > bymax, axmax < bxmin, aymax < bymin with
| true , true , _ , _ -> norm2 (axmin -. bxmax) (aymin -. bymax)
| _ , _ , true , true -> norm2 (axmax -. bxmin) (aymax -. bymin)
| true , _ , _ , true -> norm2 (axmin -. bxmax) (aymax -. bymin)
| _ , true , true , _ -> norm2 (axmax -. bxmin) (aymin -. bymax)
| false, true , false, _ -> norm2 0. (aymin -. bymax)
| false, _ , false, true -> norm2 0. (aymax -. bymin)
| true , false, _ , false -> norm2 (axmin -. bxmax) 0.
| _ , false, true , false -> norm2 (axmax -. bxmin) 0.
| false, false, false, false -> 0.
let dist_min_point ({x=px;y=py} as p) s =
(* TODO simplify *)
let is_possible_at a = is_possible (bounding_box a) (px,py,px,py) in
let nmax = 2.**(float_of_int (!inter_depth+1)) in
let rec aux a ((min,_) as pmin) t1 dt = function
| 0 ->
let t1 = float_of_int (t1 + dt/2) /. nmax in
let pt1 = point_of s t1 in
let dist = P.dist2 pt1 p in
if dist < min then (dist, t1) else pmin
| n ->
let dt = dt/2 in
let (af,al) = bisect a in
let dist_af = is_possible_at af in
let dist_al = is_possible_at al in
let doit ((min,_) as pmin) dist am t =
if dist < min then aux am pmin t dt (n-1) else pmin
in
if dist_af let t1 = float_of_int (t1 + dt/2) /. nmax in
let t2 = float_of_int (t2 + dt/2) /. nmax in
let ap = point_of s1 t1 in
let bp = point_of s2 t2 in
let dist = norm2 (ap.x -. bp.x) (ap.y -. bp.y) in
if dist < min then (dist,(t1,t2)) else pmin
| n -> let n = n-1 in
let dt = dt/2 in
let (af,al) = bisect a in
let (bf,bl) = bisect b in
let doit dist am bm t1 t2 ((min,_) as pmin) =
if dist < min then aux am bm pmin t1 t2 dt n else pmin
in
let l = [af,bf,t1,t2; af,bl,t1,t2+dt;
al,bf,t1+dt,t2;al,bl,t1+dt,t2+dt] in
let l = List.map (fun (am,bm,t1,t2) -> let dist = is_possible_at am bm in
dist, doit dist am bm t1 t2) l in
let l = List.fast_sort (fun (da,_) (db,_) -> compare da db) l in
List.fold_left (fun pmin (_,doit) -> doit pmin) pmin l in
let pmin = P.dist2 (left_point s1) (left_point s2), (0., 0.) in
aux s1 s2 pmin 0 0 (int_of_float nmax) !inter_depth
let translate t a =
{ sa = a.sa +/ t;
sb = a.sb +/ t;
sc = a.sc +/ t;
sd = a.sd +/ t}
let transform t a =
{ sa = P.transform t a.sa;
sb = P.transform t a.sb;
sc = P.transform t a.sc;
sd = P.transform t a.sd
}
mlpost-0.8.2/concrete/spline.mli 0000664 0000000 0000000 00000006150 13060465153 0016643 0 ustar 00root root 0000000 0000000 type point = Ctypes.point
type abscissa = float
type t
(** The type of Splines *)
val inter_depth : int ref
(** A mesure to decide how many iterations do to in intersection computations;
* higher means more precise *)
val debug : bool
val print : Format.formatter -> t -> unit
val create : point -> point -> point -> point -> t
(** [create a b c d] creates a spline with points a and d and
control points b and c. By default, the abscissa of the spline
starts at [0.] and ends at [1.].
*)
val create_with_offset : float -> point -> point -> point -> point -> t
(** create a spline with abscissa between [ [f,f+1] ] *)
val explode : t -> point * point * point * point
(** return the four points of the spline; left point, left control
point, second point, second control point*)
val left_point : t -> point
val left_control_point : t -> point
val right_point : t -> point
val right_control_point : t -> point
(** the four points of a spline *)
val reverse : (float -> float) -> t -> t
(** reverse a spline, using a conversion function for max and min *)
val point_of : t -> abscissa -> point
(** compute the location of the given abscissa on a spline *)
val point_of_s : t -> abscissa -> point
(** compute the location of the given abscissa on a spline, but
convert abscissa to [0,1] interval first *)
val direction : t -> abscissa -> point
(** give the direction (derivative) of the spline at the given abscissa *)
val bounding_box : t -> float * float * float * float
(** a bounding_box of the given spline *)
val precise_bounding_box : t -> float * float * float * float
(** a more precise bounding_box of the given spline *)
val one_intersection : t -> t -> float * float
(** compute a single intersection of the two splines; raise
[Not_found] if there is no intersection. *)
val intersection : t -> t -> (float * float) list
(** compute all intersections of the two splines; raise [Not_found] if there
* is no intersection. *)
val apply4 : (point -> point -> point -> point -> 'a) -> t -> 'a
(** apply a function to the four points of the spline *)
type split =
| Min
| Max
| InBetween of t * t
(** the type which caracterizes a split of a spline -
Min - we have splitted at the left end
Max - we have splitted at the right end
InBetween (s1,s2) - we have splitted somewhere in between, and the
resulting two new splines are [s1] and [s2]
*)
val split : t -> abscissa -> split
(** split a spline at the given abscissa *)
val dist_min_point : point -> t -> float * float
(** [dist_min_point p s] computes the minimal distance of [p] to [s],
as well as the abscissa which corresponds to this minimal
distance; the return value is [distance, abscissa].
*)
val dist_min_spline : t -> t -> float * (float * float)
(** [dist_min_path p1 p2] computes the minimal distance of [p1] to
[p2], as well as the two abscissa which correspond to this minimal
distance; the return value is [distance, (abscissa_on_p1,
abscissa_on_p2)].
*)
val translate : point -> t -> t
(** translate all points of the spline *)
val transform : Matrix.t -> t -> t
(** transform all points of the spline *)
mlpost-0.8.2/concrete/spline_lib.ml 0000664 0000000 0000000 00000025543 13060465153 0017327 0 ustar 00root root 0000000 0000000 (**************************************************************************)
(* *)
(* Copyright (C) Johannes Kanig, Stephane Lescuyer *)
(* Jean-Christophe Filliatre, Romain Bardou and Francois Bobot *)
(* *)
(* This software is free software; you can redistribute it and/or *)
(* modify it under the terms of the GNU Library General Public *)
(* License version 2.1, with the special exception on linking *)
(* described in file LICENSE. *)
(* *)
(* This software is distributed in the hope that it will be useful, *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *)
(* *)
(**************************************************************************)
open Format
exception Not_implemented of string
let not_implemented s = raise (Not_implemented s)
module Error = struct
let max_absc t f =
invalid_arg (f^": the abscissa given is greater than max_abscissa : "^
(string_of_float t))
let min_absc ?value f =
let value = match value with | None -> ""
| Some f -> ": "^(string_of_float f) in
invalid_arg (f^": the abscissa given is smaller than min_abscissa"^value)
let absc_point f = invalid_arg (f^": a point has only the abscissa 0.")
let dir_point f = invalid_arg (f^": a point has no direction.")
end
module P = Point_lib
type point = P.t
let id x = x
open Point_lib
open Point_lib.Infix
let rec one_to_one2 f acc a b =
List.fold_left
(fun acc ea ->
List.fold_left (fun acc eb -> f acc ea eb) acc b)
acc a
let debug = Spline.debug
type spline = Spline.t
type abscissa = Spline.abscissa
type path_ = {pl : spline list;
cycle : bool}
type path = | Point of point
| Path of path_
let is_closed = function
| Point _ -> false
| Path p -> p.cycle
let is_a_point = function
| Point p -> Some p
| Path _ -> None
let rec print_list sep prf fmt = function
| [] -> ()
| [x] -> prf fmt x
| (x::xs) -> prf fmt x; sep fmt (); print_list sep prf fmt xs
let semicolon fmt () = Format.fprintf fmt ";@ "
let print_splines = print_list semicolon Spline.print
let print fmt = function
| Point p -> fprintf fmt "@[Point %a@]" P.print p
| Path p -> fprintf fmt "@[cycle : %b; %a@]" p.cycle print_splines p.pl
let create_point p = Point p
let create a b c d =
Path {pl = [Spline.create a b c d ]; cycle = false}
let create_line a d = create a a d d
let create_lines = function
| [] -> assert false
| [a] -> Point a
| l ->
let rec aux = function
| [] |[_]-> []
| a::(d::_ as l) -> Spline.create a a d d :: aux l in
Path { pl = aux l; cycle = false }
let min_abscissa = function
| Path p -> 0.
| Point _ -> 0.
let length = function
| Point _ -> 0
| Path p -> List.length p.pl
let max_abscissa p = float (length p)
let with_last f p acc =
let rec aux = function
| [] -> assert false
| [e] ->
let sd = Spline.right_point e and sc = Spline.right_control_point e in
e :: (f sc sd) :: acc
| a::l -> a::(aux l)
in
{p with pl = aux p.pl}
let add_end p c d =
match p with
| Point p -> create p c c d
| Path p ->
Path (with_last (fun mb a -> Spline.create a (2. */ a -/ mb) c d) p [])
let add_end_line p d =
match p with
| Point p -> create_line p d
| Path p ->
Path (with_last (fun mb a -> Spline.create a a d d) p [])
let add_end_spline p sb sc d =
match p with
| Point p -> create p sb sc d
| Path p ->
Path (with_last (fun _ a -> Spline.create a sb sc d) p [])
let abscissa_to f pl t =
let tn,tf = truncate t, t -. floor t in
let rec aux tn l =
match tn,l with
|_,[] -> Error.max_absc t "abscissa_to"
|1,[a] when tf = 0. -> f a 1.
|0,a::l -> f a tf
|_,_::l -> aux (pred tn) l
in
if 0. > t then Error.min_absc "abscissa_to"
else aux tn pl
let abscissa_to_point p0 t =
match p0 with
| Path p -> abscissa_to Spline.point_of_s p.pl t
| Point p when t = 0. -> p
| Point _ -> Error.absc_point "abscissa_to_point"
let direction_of_abscissa p0 t =
match p0 with
| Point _ -> Error.dir_point "direction_of_abscissa"
| Path p -> abscissa_to Spline.direction p.pl t
let unprecise_bounding_box = function
| Path s ->
let (x_min,y_min,x_max,y_max) =
P.list_min_max_float Spline.bounding_box s.pl in
({x=x_min;y=y_min},{x=x_max;y=y_max})
| Point s -> s,s
let bounding_box = function
| Path s ->
let (x_min,y_min,x_max,y_max) =
P.list_min_max_float Spline.precise_bounding_box s.pl in
({x=x_min;y=y_min},{x=x_max;y=y_max})
| Point s -> (s,s)
exception Found of (float * float)
let one_intersection a b =
match a,b with
| Path a,Path b ->
(try
one_to_one2 (fun () a b ->
try raise (Found (Spline.one_intersection a b))
with Not_found -> ()) () a.pl b.pl;
if debug then Format.printf "one_intersection : Not_found@.";
raise Not_found
with Found a -> a)
| _ ->
if debug then
Format.printf "one_intersection : Not_found not two paths@.";
raise Not_found
let intersection a b =
match a,b with
| Path a,Path b ->
one_to_one2 (fun acc a b -> acc@(Spline.intersection a b)) [] a.pl b.pl
| _ -> []
let fold_left f acc = function
| Path p -> List.fold_left (fun acc s -> Spline.apply4 (f acc) s) acc p.pl
| Point _ -> acc
let iter f = function
| Path p -> List.iter (Spline.apply4 f) p.pl
| Point _ -> ()
let union_conv ap bp =
let max = max_abscissa ap in
let min = min_abscissa bp in
let diff = max-.min in
(fun x -> x +. diff)
let append_conv ap bp =
let union_conv = union_conv ap bp in
(fun x -> union_conv x +. 1.)
let ext_list = function
| [] -> assert false
| (a::_) as l -> a,l
let append ap0 sb sc bp0 =
match bp0 with
| Path bp ->
(* let conv x = append_conv ap0 bp0 x +. 1. in *)
(* let l = List.map (fun b -> Spline.set_min_max conv conv b) bp.pl in *)
let fbpconv,bpconv = ext_list bp.pl in
begin match ap0 with
| Path ap ->
let spl =
with_last (fun _ sa -> Spline.create sa sb sc
(Spline.left_point fbpconv)) ap bpconv
in Path {spl with cycle = false}
| Point p1 ->
Path {bp with pl =
(Spline.create p1 sb sc (Spline.left_point fbpconv)) ::bp.pl }
end
| Point p2 ->
match ap0 with
| Point p1 -> create p1 sb sc p2
| Path p -> add_end_spline ap0 sb sc p2
let reverse x =
match x with
| Path p as p0 ->
let conv =
let max = max_abscissa p0 in
let min = min_abscissa p0 in
let sum = max +. min in
(fun x -> sum -. x) in
let rec aux acc = function
| [] -> acc
| a::l -> aux (Spline.reverse conv a :: acc) l in
Path {p with pl = aux [] p.pl}
| Point _ as p -> p
(*left ((t^3)*(d + (3*(b - c)) - a)) +
* ((t^2)*(d - (3*b) + (2*a))) + (t*((2*c) - b - a)) + b *)
(*right 3*d - c *)
let cast_path_to_point p = function
| Path {pl=[];} -> Point p
| x -> x
(*
(((t0*tt)^3)*(d + (3*(b - c)) - a)) + (3*((((t0*tt)^2)*
(c + a - (2*b))) + (t0*tt*(b - a)))) + a
*)
let split_aux s t l =
match Spline.split s t with
| Spline.Min -> [],Path {pl=s::l;cycle=false}
| Spline.Max ->
let p =
cast_path_to_point (Spline.right_point s)
(Path {pl=l;cycle=false}) in
[s], p
| Spline.InBetween (s1,s2) -> [s1], Path {pl = s2 :: l ; cycle = false }
let split p0 t =
match p0 with
| Path p ->
let tn,tf = truncate t, t -. floor t in
let rec aux tn l =
match tn,l with
|_,[] -> Error.max_absc t "split"
|1,[a] when tf = 0. -> split_aux a 1. l
|0,a::l -> split_aux a tf l
|_,a::l -> let (p1,p2) = aux (pred tn) l in (a::p1,p2)
in
if 0. > t then Error.min_absc "split"
else let (p1,p2) = aux tn p.pl in
cast_path_to_point (Spline.left_point (List.hd p.pl))
(Path {pl=p1;cycle = false}),p2
| Point _ when t = 0. -> p0,p0
| Point _ -> Error.absc_point "split"
let subpath p t1 t2 =
assert (t1 <= t2);
let t2 =
if ceil t1 = ceil t2 then (t2 -. t1)/.((ceil t1) -. t1)
else t2 -. (floor t1) in
(* TODO implement it in a more efficient way *)
fst (split (snd (split p t1)) t2)
let cut_before a b =
(* TODO implement it in a more efficient way *)
try
let t = (fst (one_intersection b a)) in
let res = snd (split b t) in
(* Format.printf "t : %f@.point %a@.b : %a@.res : %a@."
t P.print (abscissa_to_point b t) print b print res;*)
res
with Not_found -> b
let cut_after a b =
(* TODO implement it in a more efficient way *)
try
let b = reverse b in
reverse (snd (split b (fst (one_intersection b a))))
with Not_found -> b
let dicho_split x = assert false
let dist_min_point p point =
match p with
| Path p ->
begin match p.pl with
| [] -> assert false
| x::xs ->
let m = Spline.dist_min_point point x in
List.fold_left (fun ((d1,_) as m1) x ->
let ((d2,_) as m2) = Spline.dist_min_point point x in
if d1 < d2 then m1 else m2) m xs
end
| Point p -> P.dist2 p point, 0.
let dist_min_path p1 p2 =
match p1, p2 with
| Path p1, Path p2 ->
begin match p1.pl, p2.pl with
| [], _ | _, [] -> assert false
| x::xs, y :: ys ->
let acc = Spline.dist_min_spline x y in
one_to_one2 (fun ((d1,_) as m1) a b ->
let (d2,_) as m2 = Spline.dist_min_spline a b in
if d1 < d2 then m1 else m2) acc xs ys
end
|Path _ as p1, Point p2 ->
let d,a = dist_min_point p1 p2 in
d, (a, 0.)
|Point p1, (Path _ as p2) ->
let d,a = dist_min_point p2 p1 in
d, (0., a)
|Point p1, Point p2 ->
P.dist2 p1 p2, (0.,0.)
let translate t p =
match p with
| Path p ->
Path {p with pl=List.map (Spline.translate t) p.pl}
| Point p -> Point (p +/ t)
let transform t = function
| Path p -> Path {p with pl= List.map (Spline.transform t) p.pl}
| Point p -> Point (P.transform t p)
let buildcycle p1 p2 = not_implemented ("buildcycle")
let close = function
| Path p1 (* TODO: tester si il est fermé*) ->
Path {p1 with cycle = true}
| Point _ -> invalid_arg ("This path cannot be closed")
let of_bounding_box ({x=x_min;y=y_min},{x=x_max;y=y_max}) =
let dl = {x=x_min;y=y_min} in
let dr = {x=x_max;y=y_min} in
let ul = {x=x_min;y=y_max} in
let ur = {x=x_max;y=y_max} in
close (create_lines [ul;ur;dr;dl;ul])
mlpost-0.8.2/concrete/spline_lib.mli 0000664 0000000 0000000 00000011111 13060465153 0017462 0 ustar 00root root 0000000 0000000 (**************************************************************************)
(* *)
(* Copyright (C) Johannes Kanig, Stephane Lescuyer *)
(* Jean-Christophe Filliatre, Romain Bardou and Francois Bobot *)
(* *)
(* This software is free software; you can redistribute it and/or *)
(* modify it under the terms of the GNU Library General Public *)
(* License version 2.1, with the special exception on linking *)
(* described in file LICENSE. *)
(* *)
(* This software is distributed in the hope that it will be useful, *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *)
(* *)
(**************************************************************************)
type point = Point_lib.t
type abscissa = Spline.abscissa
type path_ =
{pl : Spline.t list;
cycle : bool}
type path =
| Point of point
| Path of path_
val is_closed : path -> bool
val is_a_point : path -> point option
val create : point -> point -> point -> point -> path
(** create a b c d return a path with :
- point a as the starting point,
- point b as its control point,
- point d as the ending point,
- point c as its control point *)
val create_point : point -> path
(** create a path consisting of a single point *)
val create_line : point -> point -> path
(** create a straight line between two points *)
val create_lines : point list -> path
(** create a path consisting of straight lines connecting the points
in argument *)
val close : path -> path
(** close a path *)
val min_abscissa : path -> abscissa
val max_abscissa : path -> abscissa
val length : path -> int
(** number of vertex *)
val add_end : path -> point -> point -> path
(** add_end p a b return the path p with one more spline at the end.*)
val add_end_line : path -> point -> path
val add_end_spline : path -> point -> point -> point -> path
val append : path -> point -> point -> path -> path
val reverse : path -> path
(** reverse p return the path p reversed *)
(*val union : path -> path -> path (** union p1 p2 return the union of
path p1 and p2. [min_abscissa p1;max_abscissa p1] are points of p1,
]max_abscissa p1;max_abscissa p1+max_abscissa p2-min_abscissa p2]
are points of p2 *)
val union_conv : path -> path -> (abscissa -> abscissa)
*)
val one_intersection : path -> path -> (abscissa * abscissa)
val intersection : path -> path -> (abscissa * abscissa) list
(** intersection p1 p2 return a list of pair of abscissa. In each
pairs (a1,a2), a1 (resp. a2) is the abscissa in p1 (resp. p2) of
one intersection point between p1 and p2. Additionnal point of
intersection (two point for only one real intersection) can
appear in degenerate case. *)
val fold_left : ('a -> point -> point -> point -> point -> 'a)
-> 'a -> path -> 'a
(** fold on all the splines of a path *)
val iter : (point -> point -> point -> point -> unit) -> path -> unit
(** iter on all the splines of a path *)
val cut_before : path -> path -> path
val cut_after : path -> path -> path
(** remove the part of a path before the first intersection
or after the last*)
val split : path -> abscissa -> path * path
val subpath : path -> abscissa -> abscissa -> path
val direction_of_abscissa : path -> abscissa -> point
val abscissa_to_point : path -> abscissa -> point
val bounding_box : path -> point * point
val unprecise_bounding_box : path -> point * point
val dist_min_point : path -> point -> float * abscissa
(** [dist_min_point p s] computes the minimal distance of [p] to [s],
as well as the abscissa which corresponds to this minimal
distance; the return value is [distance, abscissa].
*)
val dist_min_path : path -> path -> float * (abscissa * abscissa)
(** [dist_min_path p1 p2] computes the minimal distance of [p1] to
[p2], as well as the two abscissa which correspond to this minimal
distance; the return value is [distance, (abscissa_on_p1,
abscissa_on_p2)].
*)
val translate : point -> path -> path
val transform : Matrix.t -> path -> path
val buildcycle : path -> path -> path
val of_bounding_box : point * point -> path
val print : Format.formatter -> path -> unit
val print_splines : Format.formatter -> Spline.t list -> unit
mlpost-0.8.2/concrete/unionfind.ml 0000664 0000000 0000000 00000006047 13060465153 0017176 0 ustar 00root root 0000000 0000000 (**************************************************************************)
(* *)
(* Copyright (C) Johannes Kanig, Stephane Lescuyer *)
(* Jean-Christophe Filliatre, Romain Bardou and Francois Bobot *)
(* *)
(* This software is free software; you can redistribute it and/or *)
(* modify it under the terms of the GNU Library General Public *)
(* License version 2.1, with the special exception on linking *)
(* described in file LICENSE. *)
(* *)
(* This software is distributed in the hope that it will be useful, *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *)
(* *)
(**************************************************************************)
(* This is code which has been taken from
(* Ocamlgraph: a generic graph library for OCaml *)
(* Copyright (C) 2004-2008 *)
(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *)
and has been modified since then by the Mlpost authors *)
module M = struct
type t = int * int
let equal = Pervasives.(=)
let compare = Pervasives.compare
let hash = Hashtbl.hash
end
type elt = float * float
type inputelt = M.t
module H = Hashtbl.Make(M)
type cell = {
mutable c : int;
mutable data : elt;
mutable father : cell
}
type t = cell H.t (* a forest *)
let init l =
let h = H.create 997 in
List.iter
(fun ((a,b) as x) ->
let t = float_of_int a, float_of_int b in
let rec cell = { c = 1; data = t; father = cell } in
H.add h x cell)
l;
h
let rec find_aux cell =
if cell.father == cell then
cell
else
let r = find_aux cell.father in
cell.father <- r;
r
let find x h = (find_aux (H.find h x)).data
let avg ra rb =
let ax,ay = ra.data and bx,by = rb.data in
let ac = float_of_int ra.c and bc = float_of_int rb.c in
let z = ac +. bc in
(ac *. ax +. bc *. bx) /. z, (ac *. ay +. bc *. by) /. z
let union x y h =
let rx = find_aux (H.find h x) in
let ry = find_aux (H.find h y) in
if rx != ry then begin
if rx.c > ry.c then begin
ry.father <- rx;
rx.data <- avg rx ry;
rx.c <- rx.c + ry.c
end else if rx.c < ry.c then begin
rx.father <- ry;
ry.data <- avg rx ry;
ry.c <- rx.c + ry.c
end else begin
ry.father <- rx;
rx.data <- avg rx ry;
rx.c <- rx.c + ry.c
end
end
let fold_classes f acc h =
let seen = Hashtbl.create 127 in
H.fold
(fun _ v acc ->
let r = find_aux v in
let d = r.data in
if Hashtbl.mem seen r then acc
else (Hashtbl.add seen r () ;f d acc)
) h acc
mlpost-0.8.2/concrete/unionfind.mli 0000664 0000000 0000000 00000003637 13060465153 0017351 0 ustar 00root root 0000000 0000000 (**************************************************************************)
(* *)
(* Copyright (C) Johannes Kanig, Stephane Lescuyer *)
(* Jean-Christophe Filliatre, Romain Bardou and Francois Bobot *)
(* *)
(* This software is free software; you can redistribute it and/or *)
(* modify it under the terms of the GNU Library General Public *)
(* License version 2.1, with the special exception on linking *)
(* described in file LICENSE. *)
(* *)
(* This software is distributed in the hope that it will be useful, *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *)
(* *)
(**************************************************************************)
(* This is code which has been taken from *)
(* Ocamlgraph: a generic graph library for OCaml *)
(* Copyright (C) 2004-2008 *)
(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *)
(* and has been modified since then by the Mlpost authors *)
(* Unionfind structure over tuples of ints. Representatives contain the average
* of their class, so they are of type float * float *)
type elt = float * float
type inputelt = int * int
type t
val init : inputelt list -> t
val find : inputelt -> t -> elt
val union : inputelt -> inputelt -> t -> unit
(* merge two classes and compute new average *)
val fold_classes : (elt -> 'a -> 'a) -> 'a -> t -> 'a
mlpost-0.8.2/configure.in 0000664 0000000 0000000 00000023372 13060465153 0015362 0 ustar 00root root 0000000 0000000 ##########################################################################
# #
# Copyright (C) Johannes Kanig, Stephane Lescuyer #
# Jean-Christophe Filliatre, Romain Bardou and Francois Bobot #
# #
# This software is free software; you can redistribute it and/or #
# modify it under the terms of the GNU Library General Public #
# License version 2.1, with the special exception on linking #
# described in file LICENSE. #
# #
# This software is distributed in the hope that it will be useful, #
# but WITHOUT ANY WARRANTY; without even the implied warranty of #
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. #
# #
##########################################################################
# the script generated by autoconf from this input will set the following
# variables:
# OCAMLC "ocamlc" if present in the path, or a failure
# or "ocamlc.opt" if present with same version number as ocamlc
# OCAMLOPT "ocamlopt" (or "ocamlopt.opt" if present), or "no"
# OCAMLBEST either "byte" if no native compiler was found,
# or "opt" otherwise
# OCAMLDEP "ocamldep"
# OCAMLLEX "ocamllex" (or "ocamllex.opt" if present)
# OCAMLYACC "ocamlyac"
# OCAMLLIB the path to the ocaml standard library
# OCAMLVERSION the ocaml version number
# OCAMLWEB "ocamlweb" (not mandatory)
# OCAMLWIN32 "yes"/"no" depending on Sys.os_type = "Win32"
# EXE ".exe" if OCAMLWIN32=yes, "" otherwise
# The name of the package and its version
AC_INIT(mlpost,0.8.2,[],[],[])
# The compilation date
TODAY=`date`
# Check for Ocaml compilers
# we first look for ocamlc in the path; if not present, we fail
AC_PATH_PROG(OCAMLC,ocamlc,no)
if test "$OCAMLC" = no ; then
AC_MSG_ERROR(Cannot find ocamlc.)
fi
# we extract Ocaml version number and library path
OCAMLVERSION=`$OCAMLC -v | sed -n -e 's|.*version *\(.*\)$|\1|p' `
echo "ocaml version is $OCAMLVERSION"
OCAMLLIB=`$OCAMLC -v | tail -1 | cut -f 4 -d " "`
if test "$OCAMLLIB" != ${OCAMLLIB#/usr} -a \
-d /usr/local${OCAMLLIB#/usr}; then
OCAMLLIBLOCAL=/usr/local${OCAMLLIB#/usr}
echo "ocaml library path is $OCAMLLIB and $OCAMLLIBLOCAL"
else
echo "ocaml library path is $OCAMLLIB"
fi
case $OCAMLVERSION in
1.*|2.*|3.*)
AC_MSG_ERROR(Mlpost doesn't support OCaml version smaller than 4.0. Aborting.)
;;
esac
# then we look for ocamlopt; if not present, we issue a warning
# if the version is not the same, we also discard it
# we set OCAMLBEST to "opt" or "byte", whether ocamlopt is available or not
AC_PATH_PROG(OCAMLOPT,ocamlopt,no)
OCAMLBEST=byte
if test "$OCAMLOPT" = no ; then
AC_MSG_WARN(Cannot find ocamlopt; bytecode compilation only.)
else
AC_MSG_CHECKING(ocamlopt version)
TMPVERSION=`$OCAMLOPT -v | sed -n -e 's|.*version *\(.*\)$|\1|p' `
if test "$TMPVERSION" != "$OCAMLVERSION" ; then
AC_MSG_RESULT(differs from ocamlc; ocamlopt discarded.)
OCAMLOPT=no
else
AC_MSG_RESULT(ok)
OCAMLBEST=opt
fi
fi
# checking for ocamlc.opt
AC_PATH_PROG(OCAMLCDOTOPT,ocamlc.opt,no)
if test "$OCAMLCDOTOPT" != no ; then
AC_MSG_CHECKING(ocamlc.opt version)
TMPVERSION=`$OCAMLCDOTOPT -v | sed -n -e 's|.*version *\(.*\)$|\1|p' `
if test "$TMPVERSION" != "$OCAMLVERSION" ; then
AC_MSG_RESULT(differs from ocamlc; ocamlc.opt discarded.)
else
AC_MSG_RESULT(ok)
OCAMLC=$OCAMLCDOTOPT
fi
fi
# checking for ocamlopt.opt
if test "$OCAMLOPT" != no ; then
AC_PATH_PROG(OCAMLOPTDOTOPT,ocamlopt.opt,no)
if test "$OCAMLOPTDOTOPT" != no ; then
AC_MSG_CHECKING(ocamlc.opt version)
TMPVER=`$OCAMLOPTDOTOPT -v | sed -n -e 's|.*version *\(.*\)$|\1|p' `
if test "$TMPVER" != "$OCAMLVERSION" ; then
AC_MSG_RESULT(differs from ocamlc; ocamlopt.opt discarded.)
else
AC_MSG_RESULT(ok)
OCAMLOPT=$OCAMLOPTDOTOPT
fi
fi
fi
# checking for camlp4o
AC_PATH_PROG(CAMLP4O,camlp4o,no)
if test "$CAMLP4O" != no ; then
AC_MSG_CHECKING(camlp4o version)
TMPVER=`$CAMLP4O -version`
if test "$TMPVER" != "$OCAMLVERSION" ; then
AC_MSG_ERROR(differs from ocamlc; Aborting.)
else
AC_MSG_RESULT(ok)
fi
fi
# currently commented out because some other part of the code relies on
# camlp4o in bytecode
#AC_PATH_PROG(CAMLP4ODOTOPT, camlp4o.opt,no)
#if test "$CAMLP4ODOTOPT" != no ; then
# AC_MSG_CHECKING(camlp4o.opt version)
# TMPVER=`$CAMLP4ODOTOPT -version`
# if test "$TMPVER" != "$OCAMLVERSION" ; then
# AC_MSG_ERROR(differs from ocamlc; Aborting.)
# else
# AC_MSG_RESULT(ok)
# CAMLP4O=$CAMLP4ODOTOPT
# fi
#fi
#checking for ocamldoc
AC_PATH_PROG(OCAMLDOC,ocamldoc,no)
# ocamldep, ocamllex and ocamlyacc should also be present in the path
AC_PATH_PROG(OCAMLDEP,ocamldep,no)
if test "$OCAMLDEP" = no ; then
AC_MSG_ERROR(Cannot find ocamldep.)
fi
AC_PATH_PROG(OCAMLLEX,ocamllex,no)
if test "$OCAMLLEX" = no ; then
AC_MSG_ERROR(Cannot find ocamllex.)
else
AC_PATH_PROG(OCAMLLEXDOTOPT,ocamllex.opt,no)
if test "$OCAMLLEXDOTOPT" != no ; then
OCAMLLEX=$OCAMLLEXDOTOPT
fi
fi
AC_PATH_PROG(OCAMLYACC,ocamlyacc,no)
if test "$OCAMLYACC" = no ; then
AC_MSG_ERROR(Cannot find ocamlyacc.)
fi
#First check that the versions for ocamlbuild are OK
AC_PATH_PROG(OCAMLBUILD, ocamlbuild, no)
if test "$OCAMLBUILD" = no; then
AC_MSG_ERROR(Cannot find ocamlbuild.)
else
AC_MSG_RESULT(ok)
fi
AC_PATH_PROG(OCAMLWEB,ocamlweb,true)
# platform
AC_MSG_CHECKING(platform)
if echo "let _ = Sys.os_type" | ocaml | grep -q Win32; then
AC_MSG_RESULT(Win32)
OCAMLWIN32=yes
EXE=.exe
LIBEXT=.lib
OBJEXT=.obj
else
AC_MSG_RESULT(not Win32)
OCAMLWIN32=no
EXE=
LIBEXT=.a
OBJEXT=.o
fi
## Where are the library we need
# we look for ocamlfind; if not present, we just don't use it to find
# libraries
AC_CHECK_PROG(USEOCAMLFIND,ocamlfind,yes,no)
if test "$USEOCAMLFIND" = no; then
AC_MSG_ERROR(Cannot find ocamlfind.)
fi
OCAMLFINDLIB=$(ocamlfind printconf stdlib)
OCAMLFIND=$(which ocamlfind)
if test "$OCAMLFINDLIB" != "$OCAMLLIB"; then
echo "ocamlfind : $OCAMLFINDLIB, ocamlc : $OCAMLLIB"
AC_MSG_ERROR(Your ocamlfind is not compatible with your ocamlc.)
fi
if test "$LIBDIR" = ""; then
LIBDIR=$(ocamlfind printconf destdir)/mlpost
fi
echo "Mlpost library will be installed in: $LIBDIR"
AC_ARG_ENABLE(cairo,
[ --enable-cairo enable the cairo backend (requires cairo library, implies --enable-concrete)[default=yes]],,
enable_cairo=yes)
CAIRO=no
if test "$enable_cairo" = yes; then
# checking for mlcairo
CAIROLIB=$(ocamlfind query cairo)
if test -n "$CAIROLIB";then
echo "ocamlfind found cairo in $CAIROLIB"
CAIRO=yes
fi
fi
AC_ARG_ENABLE(concrete,
[ --enable-concrete enable concrete computations (requires bitstring library) [default=yes]],,
enable_concrete=yes)
BITSTRING=no
if test "$enable_concrete" = yes; then
BITSTRINGLIB=$(ocamlfind query bitstring)
if test -n "$BITSTRINGLIB";then
echo "ocamlfind found bitstring in $BITSTRINGLIB"
BITSTRING=yes
fi
fi
if test "$BITSTRING" = yes; then
if test "$CAIRO" = yes; then
TAGS="-tags cairo_yes,concrete_yes"
INCLUDELIBS="-I $CAIROLIB -I $BITSTRINGLIB"
METAREQUIRESPACKAGE="unix cairo bitstring"
else
CAIRO=no
TAGS="-tag concrete_yes"
INCLUDELIBS="-I $BITSTRINGLIB"
METAREQUIRESPACKAGE="unix bitstring"
fi
else
CAIRO=no
BITSTRING=no
TAGS=""
INCLUDELIBS=""
METAREQUIRESPACKAGE="unix"
fi
#TEMPORAIRE
#CAIRO=no
#INCLUDELIBS=""
AC_ARG_ENABLE(lablgtk,
[ --enable-lablgtk enable the cairo backend (requires cairo library, implies --enable-lablgtk)[default=yes]],,
enable_lablgtk=yes)
LABLGTK2=no
if test "$enable_lablgtk" = yes; then
# checking for lablgtk2
LABLGTK2LIB=$(ocamlfind query lablgtk2)
if test -n "$LABLGTK2LIB";then
echo "ocamlfind found lablgtk2 in $LABLGTK2LIB"
fi
fi
if test -n "$LABLGTK2LIB" ; then
LABLGTK2=yes
INCLUDEGTK2="-I +lablgtk2"
else
LABLGTK2=no
fi
# checking for cairo.lablgtk2
CAIROLABLGTK2LIB=$(ocamlfind query cairo.lablgtk2)
if test -n "$CAIROLABLGTK2LIB";then
echo "ocamlfind found cairo.lablgtk2 in $CAIROLABLGTK2LIB"
fi
if test -n "$LABLGTK2LIB" ; then
CAIROLABLGTK2=yes
else
CAIROLABLGTK2=no
fi
#Viewer for ps and pdf
AC_CHECK_PROGS(PSVIEWER,gv evince)
AC_CHECK_PROGS(PDFVIEWER,xpdf acroread evince)
# substitutions to perform
AC_SUBST(OCAMLC)
AC_SUBST(OCAMLOPT)
AC_SUBST(CAMLP4O)
AC_SUBST(OCAMLDOC)
AC_SUBST(OCAMLDEP)
AC_SUBST(OCAMLLEX)
AC_SUBST(OCAMLYACC)
AC_SUBST(OCAMLBEST)
AC_SUBST(OCAMLVERSION)
AC_SUBST(OCAMLWEB)
AC_SUBST(OCAMLFIND)
AC_SUBST(OCAMLBUILD)
AC_SUBST(LABLGTK2)
AC_SUBST(INCLUDEGTK2)
AC_SUBST(LABLGTK2LIB)
AC_SUBST(CAIROLABLGTK2)
AC_SUBST(CAIROLABLGTK2LIB)
AC_SUBST(TAGS)
AC_SUBST(CAIROLIB)
AC_SUBST(INCLUDELIBS)
AC_SUBST(BITSTRINGLIB)
AC_SUBST(OCAMLWIN32)
AC_SUBST(EXE)
AC_SUBST(LIBEXT)
AC_SUBST(OBJEXT)
AC_SUBST(LIBDIR)
AC_SUBST(PACKAGE_VERSION)
AC_SUBST(TODAY)
AC_SUBST(METAREQUIRESPACKAGE)
echo "---------------------------------------------------"
echo " Mlpost library will be installed in: $LIBDIR"
echo -n " native code compilation: "
if test "$OCAMLBEST" == "opt"; then echo "yes"; else echo "no"; fi
echo " Support for concrete computations in mlpost: "$BITSTRING
echo " Cairo support in mlpost: "$CAIRO
echo " Contrib mlpost_lablgtk : "$LABLGTK2
echo "---------------------------------------------------"
# Finally create the Makefile from Makefile.in
AC_CONFIG_FILES(META version.ml Makefile myocamlbuild.ml)
AC_OUTPUT
chmod a-w Makefile
chmod a-w myocamlbuild.ml
chmod a-w META
chmod a-w version.ml
mlpost-0.8.2/contrib/ 0000775 0000000 0000000 00000000000 13060465153 0014502 5 ustar 00root root 0000000 0000000 mlpost-0.8.2/contrib/dot/ 0000775 0000000 0000000 00000000000 13060465153 0015270 5 ustar 00root root 0000000 0000000 mlpost-0.8.2/contrib/dot/META 0000664 0000000 0000000 00000000265 13060465153 0015744 0 ustar 00root root 0000000 0000000 description = "Library for Mlpost which use dot to place Box, Picture, ..."
version = "0.1"
archive(byte) = "mlpost_dot.cma"
archive(native) = "mlpost_dot.cmxa"
requires = "mlpost"
mlpost-0.8.2/contrib/dot/Makefile 0000664 0000000 0000000 00000000621 13060465153 0016727 0 ustar 00root root 0000000 0000000 BUILD=_build
# TO suppress
OCAMLBUILD=ocamlbuild
OCAMLFIND=ocamlfind
all :
$(OCAMLBUILD) -I $(MLPOST_LIB) -tag dtypes -no-links mlpost_dot.cma mlpost_dot.cmxa mlpost_dot.a dot.cmi -classic-display
install :
$(OCAMLFIND) remove mlpost_dot
$(OCAMLFIND) install mlpost_dot $(BUILD)/mlpost_dot.cma $(BUILD)/mlpost_dot.cmxa $(BUILD)/mlpost_dot.a $(BUILD)/dot.cmi META
clean :
$(OCAMLBUILD) -clean mlpost-0.8.2/contrib/dot/_tags 0000664 0000000 0000000 00000000066 13060465153 0016312 0 ustar 00root root 0000000 0000000 <*.cmx> and not : for-pack(Mlpost_dot) mlpost-0.8.2/contrib/dot/dot.ml 0000664 0000000 0000000 00000007761 13060465153 0016423 0 ustar 00root root 0000000 0000000 open Xdot_ast
open Mlpost
let parse_file f =
let f = open_in f in
let f = Lexing.from_channel f in
let d = Xdot_lexer.main f in
d
module Pi = Picture
let ip (x,y) = (*Format.printf "%i,%i@." x y;*) Point.bpp (x,y)
let interp_node (id,pos) =
let t = Pi.tex ("mlpost_node"^string_of_int id) in
let t = Pi.shift (ip pos) t in
t
(* http://lists.cairographics.org/archives/cairo/2009-April/016916.html *)
open Num
open Command
module P = Point
(*
let bezier_of_bspline l =
let spline = Array.of_list l in
let q0 = P.scale (bp (1./.6.0)) (P.add (P.add spline.(0) (P.scale (bp 4.0)
spline.(1))) spline.(2)) in
let lastpt = Array.length spline - 3 in
let path = ref (MetaPath.start (MetaPath.knotp q0)) in
for i = 0 to lastpt-1 do
let p1 = spline.(i + 1) in
let p2 = spline.(i + 2) in
let p3 = spline.(i + 3) in
let q1 = P.add (P.scale (bp (4.0/.6.0)) p1) (P.scale (bp (2.0/.6.0)) p2) in
let q2 = P.add (P.scale (bp (2.0/.6.0)) p1) (P.scale (bp (4.0/.6.0)) p2) in
let q3 = P.scale (bp (1./.6.0)) (P.add (P.add p1 (P.scale (bp 4.0) p2))
p3) in
path :=
MetaPath.concat ~style:(MetaPath.jControls q1 q2) (!path) (MetaPath.knotp q3)
done;
MetaPath.to_path !path
*)
let bezier_of_point_list = function
| [] -> invalid_arg "Need at least one point"
| a::l ->
let rec aux acc = function
| [] -> acc
| [_]|[_;_] -> invalid_arg "not enough point (k*3 +1)"
| a::b::c::l -> aux (MetaPath.concat ~style:(MetaPath.jControls a b)
acc (MetaPath.knotp c)) l in
MetaPath.to_path (aux (MetaPath.start (MetaPath.knotp a)) l)
let interp_spline l =
let l = List.map ip l in
let p = bezier_of_point_list l in
p
let interp_edge (_,_,path) = interp_spline path
open Format
let print_nodes fmt l =
List.iter
(fun (n,w,h) ->
fprintf fmt "%s [width=%f,height=%f];@." n (w/.72.) (h/.72.)) l
let print_edges fmt l =
List.iter (fun (x,y) -> fprintf fmt "%s -> %s;@." x y) l
let print_dot fmt rankdir nodes edges =
fprintf fmt
"@[digraph G {@[
graph [rankdir=%s];
node [label=\"\",shape=\"box\"];
edge [dir=none];
@[%a@]
@[%a@]
@]}@]" rankdir print_nodes nodes print_edges edges
let call_dot orient nodes edges =
let rankdir = match orient with
| `TB -> "TB"
| `LR -> "LR"
| `BT -> "BT"
| `RL -> "RL" in
let ((pin,pout) as p) = Unix.open_process
"dot -Txdot" in
(*"tee example_in.log | dot -Txdot |tee example_out.log" in*)
(*"cat example_out.log" in*)
let pout2 = formatter_of_out_channel pout in
print_dot pout2 rankdir nodes edges;
pp_print_flush pout2 ();
flush pout;
close_out pout;
let pin = Lexing.from_channel pin in
let d = Xdot_lexer.main pin in
match Unix.close_process p with
| Unix.WEXITED 0 -> d
| _ -> invalid_arg ("Dot doesn't like this graph")
(** User interface *)
module Make (B : Signature.Boxlike) =
struct
type node = { id : int;
fig : B.t}
type edge = node * node
let rec assoc_node n = function
| [] -> raise Not_found
| a::_ when a.id = n -> a.fig
| _::l -> assoc_node n l
let mknode =
let c = ref (-1) in
fun x -> incr c;
{id = !c; fig = x}
let mkedge s e = (s,e)
let mkedges l = l
let node_name id = Xdot_lexer.node_name id
let place ?(orient:[`TB|`LR|`BT|`RL]=`TB) nodes edges =
let nodes2 = List.map
(fun n -> node_name n.id,
Concrete.float_of_num (B.width n.fig),
Concrete.float_of_num (B.height n.fig)) nodes in
let edges =
List.map (fun (n1,n2) -> (node_name n1.id,node_name n2.id)) edges in
let d = call_dot orient nodes2 edges in
(*printf "d.nodes : %i@.d.edges : %i"
(List.length d.nodes) (List.length d.edges);*)
let nodes = List.map (fun (n,p) ->
let fig = assoc_node n nodes in
B.set_pos (ip p) fig) d.nodes in
let edges = List.map interp_edge d.edges in
(nodes,(edges:Mlpost.Path.t list))
end
mlpost-0.8.2/contrib/dot/dot.mli 0000664 0000000 0000000 00000000500 13060465153 0016554 0 ustar 00root root 0000000 0000000 open Mlpost
module Make (B : Signature.Boxlike) :
sig
type node
type edge = node * node
val mknode : B.t -> node
val mkedge : node -> node -> edge
val mkedges : (node * node) list -> edge list
val place :
?orient:[`TB|`LR|`BT|`RL] ->
node list -> edge list -> B.t list * Path.t list
end
mlpost-0.8.2/contrib/dot/mlpost_dot.mli 0000664 0000000 0000000 00000001652 13060465153 0020163 0 ustar 00root root 0000000 0000000 (** Place figures, boxes or boxlikes with graphviz *)
open Mlpost
module Dot :
sig
module Make (B : Signature.Boxlike) :
sig
type node
type edge = node * node
val mknode : B.t -> node
(** creates an abstract node from a boxlike *)
val place :
?orient:[`TB|`LR|`BT|`RL] ->
node list -> edge list -> B.t list * Path.t list
(** [place ~orient nodes edges] returns a concrete
representation of the abstract directed graph composed by
[nodes] linked by [edges]. The concrete representation is
composed by the list of all the boxlikes of [nodes] placed
by dot and by the list of paths representing the [edges]
drawn by dot
@param orient specifies the orientation of the graph :
- `TB top to bottom (default)
- `LR left to right
- `BT bottom to top
- `RL right to left
*)
end
end
mlpost-0.8.2/contrib/dot/mlpost_dot.mlpack 0000664 0000000 0000000 00000000032 13060465153 0020640 0 ustar 00root root 0000000 0000000 Xdot_parser
Xdot_lexer
Dot mlpost-0.8.2/contrib/dot/xdot_ast.mli 0000664 0000000 0000000 00000000623 13060465153 0017621 0 ustar 00root root 0000000 0000000 type statement =
| Graph of (string * string) list
| Node of int * (string * string) list
| Edge of int * int * (string * string) list
type file = statement option list
type point = float * float
type path = point list
type node = int * point
type edge = int * int * path
type digraph = {bounding_box : point * point;
nodes : node list;
edges : edge list}
mlpost-0.8.2/contrib/dot/xdot_lexer.mll 0000664 0000000 0000000 00000011735 13060465153 0020162 0 ustar 00root root 0000000 0000000 {
open Format
open Lexing
open Xdot_parser
type error =
| IllegalCharacter of char
| UnterminatedComment
| UnterminatedString
exception Error of error
let report fmt = function
| IllegalCharacter c -> fprintf fmt "illegal character %c" c
| UnterminatedComment -> fprintf fmt "unterminated comment"
| UnterminatedString -> fprintf fmt "unterminated string"
(* lexical errors *)
let keywords = Hashtbl.create 97
let () =
List.iter
(fun (x,y) -> Hashtbl.add keywords x y)
[
"digraph", DIGRAPH;
"graph", GRAPH;
]
let newline lexbuf =
let pos = lexbuf.lex_curr_p in
lexbuf.lex_curr_p <-
{ pos with pos_lnum = pos.pos_lnum + 1; pos_bol = pos.pos_cnum }
let string_buf = Buffer.create 1024
let char_for_backslash = function
| 'n' -> '\n'
| 't' -> '\t'
| c -> c
}
let newline = '\n'
let space = [' ' '\t' '\r']
let lalpha = ['a'-'z' '_']
let ualpha = ['A'-'Z']
let alpha = lalpha | ualpha
let digit = ['0'-'9']
let ident = alpha (alpha | digit | '\'')*
let decimal_literal = ['0'-'9']+
let int = '-'? decimal_literal
let float = '-'? decimal_literal ('.' decimal_literal)?
rule token = parse
| newline
{ newline lexbuf; token lexbuf }
| space+
{ token lexbuf }
| "mlpost_node" (int as i) {NODE (int_of_string i)}
| ident as id
{ try Hashtbl.find keywords id with Not_found -> IDENT id }
| "\""
{ STRING (string lexbuf) }
| "'"
{ QUOTE }
| ","
{ COMMA }
| "("
{ LEFTPAR }
| ")"
{ RIGHTPAR }
| ":"
{ COLON }
| ";"
{ SEMICOLON }
| "->"
{ ARROW }
| "<->"
{ LRARROW }
| "."
{ DOT }
| "|"
{ BAR }
| "="
{ EQUAL }
| "["
{ LEFTSQ }
| "]"
{ RIGHTSQ }
| "{"
{ LEFTAC }
| "}"
{ RIGHTAC }
| eof
{ EOF }
| _ as c
{ raise (Error (IllegalCharacter c)) }
and pos = parse
| newline { newline lexbuf; token lexbuf }
| (float as x) {FLOAT (float_of_string x)}
| space+ {SPACE}
| ',' {COMMA}
| eof { EOF }
| _ as c
{ raise (Error (IllegalCharacter c)) }
and string = parse
| "\""
{ let s = Buffer.contents string_buf in
Buffer.clear string_buf;
s }
| "\\" (_ as c)
{ Buffer.add_char string_buf (char_for_backslash c); string lexbuf }
| newline
{ newline lexbuf; Buffer.add_char string_buf '\n'; string lexbuf }
| eof
{ raise (Error UnterminatedString) }
| _ as c
{ Buffer.add_char string_buf c; string lexbuf }
{
open Xdot_ast
let (*parse_string_with*) ps_with parse s =
let lexbuf = Lexing.from_string s in
try
parse pos lexbuf
with Error e ->
Format.eprintf "mlpost_dot error (pos,path,bb) : %a@." report e;
exit 1
| Parsing.Parse_error ->
let pstart = lexeme_start_p lexbuf in
let pend = lexeme_end_p lexbuf in
Format.eprintf
"mlpost_dot(pos) parsing error at line %d, characters %d-%d@."
pstart.pos_lnum
(pstart.pos_cnum - pstart.pos_bol)
(pend.pos_cnum - pend.pos_bol);
exit 1
| e ->
Format.printf "mlpost_dot error in pos, path or bounding_box : %s@."
(Printexc.to_string e);
exit 1
let xdot_type digraph =
let bounding_box = ref None in
let nodes = ref [] in
let edges = ref [] in
List.iter (function
| None -> ()
| Some Graph l ->
begin try
bounding_box :=
Some (ps_with Xdot_parser.bounding_box
(List.assoc "bb" l))
with Not_found -> () end
| Some Node (i,l) ->
begin try
let p =
ps_with Xdot_parser.pos (List.assoc "pos" l) in
nodes := (i,p)::!nodes
with Not_found -> () end
| Some Edge (i1,i2,l) ->
begin try
let p = ps_with Xdot_parser.path (List.assoc "pos" l) in
edges := (i1,i2,p)::!edges
with Not_found -> () end) digraph;
let bounding_box = match !bounding_box with
| None ->
Format.eprintf "Dot doesn't give any bounding box!!
Please report to mlpost authors@.";
exit 1
| Some bb -> bb in
{ bounding_box = bounding_box;
edges = !edges;
nodes = !nodes}
let main f =
try
let digraph = Xdot_parser.file token f in
xdot_type digraph
with Error e ->
Format.eprintf "mlpost_dot error : %a@." report e;
exit 1
| Parsing.Parse_error ->
let pstart = lexeme_start_p f in
let pend = lexeme_end_p f in
Format.eprintf "parsing error at line %d, characters %d-%d@."
pstart.pos_lnum
(pstart.pos_cnum - pstart.pos_bol)
(pend.pos_cnum - pend.pos_bol);
exit 1
let node_name id = Format.sprintf "mlpost_node%i" id
}
(*
Local Variables:
compile-command: "unset LANG; make -C ../.. contrib"
End:
*)
mlpost-0.8.2/contrib/dot/xdot_parser.mly 0000664 0000000 0000000 00000002505 13060465153 0020347 0 ustar 00root root 0000000 0000000 %{
open Xdot_ast
open Parsing
%}
/* Tokens */
%token IDENT
%token STRING
%token INT
%token FLOAT
%token NODE
/* keywords */
%token DIGRAPH BOUNDINGBOX POS GRAPH
/* symbols */
%token ARROW
%token BAR
%token COLON COMMA SPACE SEMICOLON
%token DOT EQUAL
%token LEFTPAR LEFTPAR_STAR_RIGHTPAR LEFTSQ
%token LRARROW
%token QUOTE
%token RIGHTPAR RIGHTSQ
%token LEFTAC RIGHTAC
%token UNDERSCORE
%token EOF
/* Entry points */
%type file
%start file
%type path
%start path
%type bounding_box
%start bounding_box
%type pos
%start pos
%%
file:
| DIGRAPH IDENT LEFTAC statements RIGHTAC EOF { $4 }
statements:
| {[]}
| statement SEMICOLON statements {$1::$3}
statement:
| IDENT LEFTSQ properties RIGHTSQ {None}
| GRAPH LEFTSQ properties RIGHTSQ {Some (Graph $3)}
| NODE LEFTSQ properties RIGHTSQ {Some (Node ($1,$3))}
| NODE ARROW NODE LEFTSQ properties RIGHTSQ {Some (Edge ($1,$3,$5))}
properties:
| property {[$1]}
| property COMMA properties {$1::$3}
property:
| IDENT EQUAL STRING {($1,$3)}
| IDENT EQUAL IDENT {($1,$3)}
pos:
| pos_bas EOF {$1}
pos_bas:
| FLOAT COMMA FLOAT {($1,$3)}
path:
| pos_bas EOF {[$1]}
| pos_bas SPACE path {($1::$3)}
bounding_box:
| pos_bas COMMA pos_bas {($1,$3)}
mlpost-0.8.2/contrib/graphics/ 0000775 0000000 0000000 00000000000 13060465153 0016302 5 ustar 00root root 0000000 0000000 mlpost-0.8.2/contrib/graphics/mlpost_graphics.ml 0000664 0000000 0000000 00000005307 13060465153 0022037 0 ustar 00root root 0000000 0000000 open Mlpost
module Virtual = struct
let num i = Num.px (float i)
type t = {mutable x : int;
mutable y : int;
mutable cmds : Command.t list;
mutable color : Color.t;
mutable filename : string}
let t = {x = 0; y = 0; cmds = [];
color = Color.black;
filename="mlpost_graphics"}
let clear_graph () = t.x <- 0; t.y <- 0; t.cmds <- []; t.color <- Color.black
let get_cmds () = Command.seq t.cmds
let set_color c = t.color <- c
let red = Color.red
let blue = Color.blue
let green = Color.green
let black = Color.black
let white = Color.white
let moveto x y = t.x <- x; t.y <- y
let push c = t.cmds <- c::t.cmds
let circle x y r =
let circle = Path.scale (num r) Path.fullcircle in
let circle = Path.shift (Point.pt (num x,num y)) circle in
circle
let fill_circle x y r =
push (Path.fill ~color:t.color (circle x y r))
let lineto x y =
push (Path.draw (Path.pathn [num t.x, num t.y; num x, num y]))
let rect x y w h =
let rect = Path.unitsquare in
(* let rect = Path.shift (Point.pt (Num.bp 0.5,Num.bp 0.5)) rect in *)
let rect = Path.yscale (num h) rect in
let rect = Path.xscale (num w) rect in
let rect = Path.shift (Point.pt (num x,num y)) rect in
rect
let draw_rect x y w h =
push (Path.draw (rect x y w h))
let set_emit f = t.filename <- f
let synchronize =
at_exit (fun () -> Printf.printf "Dump!!\n%!";
Mps.dump ();Cairost.dump_png ());
let c = ref (-1) in
fun () -> incr c;
Metapost.emit (t.filename^(string_of_int !c)) (get_cmds ())
let draw_string s =
let pic = Picture.tex s in (* TODO escape character *)
let pic = Picture.shift (Point.pt (num t.x,num t.y)) pic in
push pic
end
(* Use also Graphics *)
module Double = struct
include Graphics
let clear_graph () = Virtual.clear_graph (); Graphics.clear_graph ()
let get_cmds = Virtual.get_cmds
let set_ratio = Virtual.set_ratio
let set_color (c1,c2) = Virtual.set_color c1; Graphics.set_color c2
let red = (Virtual.red,Graphics.red)
let green = (Virtual.green,Graphics.green)
let blue = (Virtual.blue,Graphics.blue)
let black = (Virtual.black,Graphics.black)
let white = (Virtual.white,Graphics.white)
let moveto x y = Virtual.moveto x y; Graphics.moveto x y
let fill_circle x y r = Virtual.fill_circle x y r;Graphics.fill_circle x y r
let lineto x y = Virtual.lineto x y; Graphics.lineto x y
let draw_rect x y w h = Virtual.draw_rect x y w h; Graphics.draw_rect x y w h
let set_emit = Virtual.set_emit
let synchronize () = Virtual.synchronize (); Graphics.synchronize ()
let draw_string s = Virtual.draw_string s;Graphics.draw_string s
end
mlpost-0.8.2/contrib/graphics/mlpost_graphics.mli 0000664 0000000 0000000 00000013620 13060465153 0022205 0 ustar 00root root 0000000 0000000 (** Library for using Mlpost through standard library graphics API *)
(** Subset of the Graphics API signature supported by Mlpost_graphics *)
module type Graphics =
sig
val open_graph : string -> unit
val close_graph : unit -> unit
val set_window_title : string -> unit
val resize_window : int -> int ->
val clear_graph : unit ->
val size_x : unit ->
val size_y : unit -> int
type color
val rgb : int -> int -> int -> color
(** [rgb r g b] returns the integer encoding the color with red
component [r], green component [g], and blue component [b].
[r], [g] and [b] are in the range [0..255]. *)
val black : color
val white : color
val red : color
val green : color
val blue : color
val yellow : color
val cyan : color
val magenta : color
val moveto : int -> int -> unit
(** Position the current point. *)
val rmoveto : int -> int -> unit
(** [rmoveto dx dy] translates the current point by the given vector. *)
val current_x : unit -> int
(** Return the abscissa of the current point. *)
val current_y : unit -> int
(** Return the ordinate of the current point. *)
val current_point : unit -> int * int
(** Return the position of the current point. *)
val lineto : int -> int -> unit
(** Draw a line with endpoints the current point and the given point,
and move the current point to the given point. *)
val rlineto : int -> int -> unit
(** Draw a line with endpoints the current point and the
current point translated of the given vector,
and move the current point to this point. *)
val curveto : int * int -> int * int -> int * int -> unit
(** [curveto b c d] draws a cubic Bezier curve starting from
the current point to point [d], with control points [b] and
[c], and moves the current point to [d]. *)
val draw_rect : int -> int -> int -> int -> unit
(** [draw_rect x y w h] draws the rectangle with lower left corner
at [x,y], width [w] and height [h].
The current point is unchanged.
Raise [Invalid_argument] if [w] or [h] is negative. *)
val draw_poly_line : (int * int) array -> unit
(** [draw_poly_line points] draws the line that joins the
points given by the array argument.
The array contains the coordinates of the vertices of the
polygonal line, which need not be closed.
The current point is unchanged. *)
val draw_poly : (int * int) array -> unit
(** [draw_poly polygon] draws the given polygon.
The array contains the coordinates of the vertices of the
polygon.
The current point is unchanged. *)
val draw_segments : (int * int * int * int) array -> unit
(** [draw_segments segments] draws the segments given in the array
argument. Each segment is specified as a quadruple
[(x0, y0, x1, y1)] where [(x0, y0)] and [(x1, y1)] are
the coordinates of the end points of the segment.
The current point is unchanged. *)
val draw_arc : int -> int -> int -> int -> int -> int -> unit
(** [draw_arc x y rx ry a1 a2] draws an elliptical arc with center
[x,y], horizontal radius [rx], vertical radius [ry], from angle
[a1] to angle [a2] (in degrees). The current point is unchanged.
Raise [Invalid_argument] if [rx] or [ry] is negative. *)
val draw_ellipse : int -> int -> int -> int -> unit
(** [draw_ellipse x y rx ry] draws an ellipse with center
[x,y], horizontal radius [rx] and vertical radius [ry].
The current point is unchanged.
Raise [Invalid_argument] if [rx] or [ry] is negative. *)
val draw_circle : int -> int -> int -> unit
(** [draw_circle x y r] draws a circle with center [x,y] and
radius [r]. The current point is unchanged.
Raise [Invalid_argument] if [r] is negative. *)
val set_line_width : int -> unit
(** Set the width of points and lines drawn with the functions above.
Under X Windows, [set_line_width 0] selects a width of 1 pixel
and a faster, but less precise drawing algorithm than the one
used when [set_line_width 1] is specified.
Raise [Invalid_argument] if the argument is negative. *)
(** {6 Text drawing} *)
val draw_char : char -> unit
(** See {!Graphics.draw_string}.*)
val draw_string : string -> unit
(** Draw a character or a character string with lower left corner
at current position. After drawing, the current position is set
to the lower right corner of the text drawn. *)
val set_font : string -> unit
(** Set the font used for drawing text.
The interpretation of the argument to [set_font]
is implementation-dependent. *)
val set_text_size : int -> unit
(** Set the character size used for drawing text.
The interpretation of the argument to [set_text_size]
is implementation-dependent. *)
val text_size : string -> int * int
(** Return the dimensions of the given text, if it were drawn with
the current font and size. *)
(** {6 Filling} *)
val fill_rect : int -> int -> int -> int -> unit
(** [fill_rect x y w h] fills the rectangle with lower left corner
at [x,y], width [w] and height [h], with the current color.
Raise [Invalid_argument] if [w] or [h] is negative. *)
val fill_poly : (int * int) array -> unit
(** Fill the given polygon with the current color. The array
contains the coordinates of the vertices of the polygon. *)
val fill_arc : int -> int -> int -> int -> int -> int -> unit
(** Fill an elliptical pie slice with the current color. The
parameters are the same as for {!Graphics.draw_arc}. *)
val fill_ellipse : int -> int -> int -> int -> unit
(** Fill an ellipse with the current color. The
parameters are the same as for {!Graphics.draw_ellipse}. *)
val fill_circle : int -> int -> int -> unit
(** Fill a circle with the current color. The
parameters are the same as for {!Graphics.draw_circle}. *)
end
(** Create only mlpost figures *)
module Virtual : Graphics
(** Create mlpost figures and call graphics function *)
module Double : Graphics
mlpost-0.8.2/contrib/lablgtk/ 0000775 0000000 0000000 00000000000 13060465153 0016122 5 ustar 00root root 0000000 0000000 mlpost-0.8.2/contrib/lablgtk/META 0000664 0000000 0000000 00000000336 13060465153 0016575 0 ustar 00root root 0000000 0000000 description = "Library for Mlpost to easily display mlpost figures into an x-window"
version = "0.1"
archive(byte) = "mlpost_lablgtk.cma"
archive(native) = "mlpost_lablgtk.cmxa"
requires = "mlpost cairo.lablgtk2 lablgtk2"
mlpost-0.8.2/contrib/lablgtk/mlpost_lablgtk.ml 0000664 0000000 0000000 00000014554 13060465153 0021503 0 ustar 00root root 0000000 0000000
(* Lablgtk - Examples *)
open StdLabels
open Mlpost
open Format
module P = Picture
type auto_aspect = width:Num.t -> height:Num.t -> P.t -> Mlpost.Transform.t
let aa_nothing ~width ~height _ = []
let aa_center ~width ~height pic =
let p = Point.pt (Num.divf width 2.,Num.divf height 2.) in
[Transform.shifted (Point.sub p (P.ctr pic))]
let aa_fit_page ~width ~height pic =
let swidth = Num.divn width (P.width pic) in
let sheight = Num.divn height (P.height pic) in
let scale = Num.minn swidth sheight in
let t = Transform.scaled scale in
t::(aa_center ~width ~height (P.transform [t] pic))
let aa_fit_width ~width ~height pic =
let swidth = Num.divn width (P.width pic) in
let t = (Transform.scaled swidth) in
t::(aa_center ~width ~height (P.transform [t] pic))
let aa_fit_height ~width ~height pic =
let sheight = Num.divn height (P.height pic) in
let t = (Transform.scaled sheight) in
t::(aa_center ~width ~height (P.transform [t] pic))
class mlpost_pic ?width ?height ?packing ?show () =
(* Create the drawing area. *)
let da = GMisc.drawing_area ?width ?height ?packing ?show () in
let drawable = lazy (new GDraw.drawable da#misc#window) in
let new_pixmap color width height =
let drawable = GDraw.pixmap ~width ~height () in
drawable#set_foreground color ;
drawable in
object (self)
inherit GObj.widget da#as_widget
val mutable need_update = true
(* The mlpost pic. *)
val mutable pic = Command.nop
method set_pic t = pic <- t; need_update <- true
method pic = pic
(* For the background color *)
val mutable background = `WHITE
method background = background
method set_background c = background <- c
(* For the aspect *)
val mutable auto_aspect = aa_nothing
method set_auto_aspect x = auto_aspect <- x
val mutable show_corner = false
method set_show_corner b = show_corner <- b
val mutable size = (1,1)
method size = size
val mutable pm = new_pixmap `WHITE 1 1
val origin = Point.origin
method private repaint () =
let drawable = Lazy.force drawable in
let (width, height) as ssize = drawable#size in
size <- ssize;
pm <- new_pixmap background width height;
(* reset the pixmap *)
pm#rectangle ~x:0 ~y:0 ~width ~height ~filled:true ();
let w,h = (float_of_int width,float_of_int height) in
(* *)
let pic = if show_corner then
let f x = Point.draw ~color:Color.red (Picture.corner x pic) in
Command.seq (pic:: (List.map f [`Center;`Northeast;`Southeast;
`Northwest;`Southwest]))
else pic in
let t = auto_aspect ~width:(Num.pt w) ~height:(Num.pt h) pic in
let pic = Picture.transform t pic in
let cr = Cairo_lablgtk.create pm#pixmap in
Cairost.emit_cairo cr (w,h) pic;
need_update<-false
(* Repaint the widget. *)
method private expose ev =
if need_update then self#repaint ();
let area = GdkEvent.Expose.area ev in
let gwin = da#misc#window in
let d = new GDraw.drawable gwin in
let x = Gdk.Rectangle.x area and y = Gdk.Rectangle.y area in
let width = Gdk.Rectangle.width area
and height = Gdk.Rectangle.height area in
d#put_pixmap
~x ~y ~xsrc:x ~ysrc:y ~width ~height pm#pixmap
initializer
ignore (da#event#connect#expose
~callback:(fun ev -> self#expose ev; false));
ignore (da#event#connect#configure
~callback:(fun _ -> need_update <- true; false));
end
module Interface =
struct
type interface = {
window : GWindow.window;
main_vbox : GPack.box;
mutable show : bool; (* The main window is shown *)
mutable picda : ((unit -> Command.t) * (mlpost_pic * GWindow.window)) list}
let new_interface ?width ?height ?title () =
let window = GWindow.window ?width ?height ?title () in
let vbox = GPack.vbox ~packing:window#add () in
let _ = GMenu.menu_bar ~packing:vbox#pack () in
ignore(window#connect#destroy ~callback:GMain.quit);
{window = window;main_vbox = vbox; show = false; picda = []}
let remove_pic window pic =
window.picda <- List.remove_assq pic window.picda
let add_pic w ?width ?height ?title ?(show_corner=false)
?(auto_aspect=aa_nothing) pic =
let window = GWindow.window ?width ?height ?title () in
let mlpost_pic = new mlpost_pic ?width ?height
~packing:window#add () in
mlpost_pic#set_pic (pic ());
mlpost_pic#set_auto_aspect auto_aspect;
mlpost_pic#set_show_corner show_corner;
w.picda <- (pic,(mlpost_pic,window))::w.picda;
ignore(window#connect#destroy
~callback:(fun () -> remove_pic w pic));
if w.show then ignore(window#show ())
let refresh w =
List.iter (fun (pic,(mlpic,_)) ->
begin try
mlpic#set_pic (pic ())
with e ->
Format.eprintf
"Error raised inside picure generation@ :@ %s@."
(Printexc.to_string e)
end;
GtkBase.Widget.queue_draw mlpic#as_widget) w.picda
(** Editor window *)
let create_option w ~packing ?label l =
(match label with
| None -> ()
| Some text -> ignore (GMisc.label ~text ~packing ()));
let menu = GMenu.menu () in
let optionmenu = GMenu.option_menu ~packing () in
optionmenu #set_menu menu;
optionmenu #set_history 3;
ignore (List.fold_left ~f:(fun group (s,(c:unit -> unit)) ->
let c () = c ();refresh w in
let menuitem = GMenu.radio_menu_item
?group
~label:s
~packing:menu#append () in
ignore(menuitem#connect#toggled c);
Some (menuitem#group)
) ~init:None l)
let create_option w = create_option w ~packing:w.main_vbox#pack
let create_text w ?label first set =
(match label with
| None -> ()
| Some text -> ignore (GMisc.label ~text ~packing:w.main_vbox#pack ()));
let text = GText.view ~packing:w.main_vbox#pack ~show:true () in
text#buffer#set_text first;
ignore (text#buffer#connect#changed
(fun () -> set (text#buffer#get_text ());refresh w))
let main w =
ignore(w.window#show ());
List.iter (fun (_,(_,window)) -> ignore(window#show ())) w.picda;
GMain.main ()
end
mlpost-0.8.2/contrib/lablgtk/mlpost_lablgtk.mli 0000664 0000000 0000000 00000005712 13060465153 0021650 0 ustar 00root root 0000000 0000000 (** Use Mlpost figures inside gtk interface. *)
open Mlpost
type auto_aspect = width:Num.t -> height:Num.t ->
Mlpost.Picture.t -> Mlpost.Transform.t
val aa_nothing : auto_aspect
val aa_center : auto_aspect
val aa_fit_page : auto_aspect
val aa_fit_width : auto_aspect
val aa_fit_height : auto_aspect
(** GTK widget which displays an mlpost picture. *)
class mlpost_pic :
?width:int -> ?height:int -> ?packing:(GObj.widget -> unit) ->
?show:bool -> unit ->
object
inherit GObj.widget
val obj : Gtk.widget Gtk.obj
method pic : Mlpost.Picture.t
(** The displayed picture *)
method set_pic : Mlpost.Picture.t -> unit
(** Sets the picture to display. This function doesn't refresh
the widget. *)
method background : GDraw.color
(** The actual background color *)
method set_background : GDraw.color -> unit
(** Sets the background color *)
method size : int * int
(** The size of the drawing area (width,height) *)
method set_auto_aspect : auto_aspect -> unit
(** define the transformation used to have a good aspect of the
picture (centered, ...) *)
method set_show_corner : bool -> unit
end
module Interface :
sig
(** {1 Abstract lablgtk in order to display Mlpost figures inside a very
simple interface} *)
type interface
(** An interface is composed by one control window and by some
display window *)
val new_interface :
?width:int -> ?height:int -> ?title:string -> unit -> interface
(** create a new interface with an empty control window *)
(** {2 Interfaces} *)
val create_text :
interface -> ?label:string -> string -> (string -> unit) -> unit
(** [create_text ~label get set] adds to the control window a text
input. [get] is the initial value, [set] is called each
times the value of the text input is changed. *)
val create_option :
interface ->
?label:string -> (string * (unit -> unit)) list -> unit
(** [create_option ~label value_list] adds to the control window a
radio menu item. [value_list] is a pair of one of the choice and
the callback function used when this choice is selected. *)
val remove_pic : interface -> (unit -> Mlpost.Command.t) -> unit
(** [remove_pic gen_pic] removes a display window created by
[add_pic gen_pic] *)
(** {2 Required function} *)
(** functions needed to see one mlpost picure : *)
val add_pic :
interface ->
?width:int -> ?height:int ->
?title:string ->
?show_corner:bool ->
?auto_aspect:auto_aspect ->
(unit -> Mlpost.Command.t) ->
unit
(** [add_pic get_pic] add a new display window. [get_pic] is
called each times the window must be refreshed. If the value
of one of the interfaces is changed, the displayed picure is
refreshed.*)
val main : interface -> unit
(** Start the main loop. During the main loop some texts or
options can be added and {!add_pic} can be called *)
end
mlpost-0.8.2/customdoc/ 0000775 0000000 0000000 00000000000 13060465153 0015042 5 ustar 00root root 0000000 0000000 mlpost-0.8.2/customdoc/Makefile 0000664 0000000 0000000 00000000067 13060465153 0016505 0 ustar 00root root 0000000 0000000 img.cmo: img.ml
ocamlc -I +ocamldoc -c -dtypes img.ml
mlpost-0.8.2/customdoc/_tags 0000664 0000000 0000000 00000000147 13060465153 0016064 0 ustar 00root root 0000000 0000000 : use_ocamldoc
: use_unix, pkg_cairo, pkg_bitstring, use_bigarray, use_libmlpost_ft mlpost-0.8.2/customdoc/all.template 0000664 0000000 0000000 00000000306 13060465153 0017346 0 ustar 00root root 0000000 0000000 \documentclass{article}
\usepackage{graphicx}
\pagestyle{empty}
\begin{document}
\includegraphics[scale=3]{all.mps}
\end{document}
%%% Local Variables:
%%% mode: latex
%%% TeX-master: t
%%% End:
mlpost-0.8.2/customdoc/img.ml 0000664 0000000 0000000 00000001551 13060465153 0016152 0 ustar 00root root 0000000 0000000 class my_gen =
object(self)
inherit Odoc_html.html
(** Return HTML code for the given text of a bar tag. *)
method html_of_img t =
match t with
| [] -> ""
| (x::r) ->
begin
match x with
| Odoc_info.Raw s -> Format.sprintf "
" s s
| _ -> ""
end
initializer
tag_functions <- ("img", self#html_of_img) :: tag_functions
end
let my_generator = new my_gen
let _ =
Odoc_args.set_doc_generator
(Some my_generator :> Odoc_args.doc_generator option) ;
(* we need to deactivate the -html option of ocamldoc, otherwise our generator
* is overwritten by the standard html generator. Ocamlbuild gives the -html
* option to ocamldoc, so this is really required *)
Odoc_args.add_option ("-html", Arg.Unit (fun () -> ()), "")
mlpost-0.8.2/customdoc/img_doc.ml 0000664 0000000 0000000 00000010141 13060465153 0016772 0 ustar 00root root 0000000 0000000 open Mlpost
open Command
open Box
open Num
module Forms = struct
let circle = draw (circle (empty ~height:(bp 5.) ~width:(bp 5.) ()))
let rect = draw (rect (empty ~height:(bp 5.) ~width:(bp 5.) ()))
let round_rect = draw (round_rect (empty ~height:(bp 5.) ~width:(bp 5.) ()))
let ellipse = draw (ellipse (empty ~width:(bp 5.) ()))
let patatoid = draw (patatoid (empty ~height:(bp 5.) ~width:(bp 10.) ()))
let tex = draw (tex "text")
end
let brect = Box.rect (empty ~height:(bp 5.) ~width:(bp 5.) ())
module Dirs = struct
let dot p = Command.draw ~pen:(Pen.scale (bp 4.) Pen.circle) (Path.pathp [p])
let ctr = seq [ draw brect; dot (ctr brect) ]
let north = seq [ draw brect; dot (north brect) ]
let south = seq [ draw brect; dot (south brect) ]
let west = seq [ draw brect; dot (west brect) ]
let east = seq [ draw brect; dot (east brect) ]
let north_west = seq [ draw brect; dot (north_west brect) ]
let south_west = seq [ draw brect; dot (south_west brect) ]
let north_east = seq [ draw brect; dot (north_east brect) ]
let south_east = seq [ draw brect; dot (south_east brect) ]
end
let cpic c = Box.pic ~stroke:None (Picture.make c)
module Size = struct
open Arrow
let head = head_triangle_full
let kind = add_foot ~head (add_head ~head (add_line empty))
let dbl_arrow =
let ar =
Arrow.point_to_point ~kind Point.origin (Point.pt (bp 10.,Num.zero))
in
cpic ar
let width = Box.draw (Box.vbox [ brect; dbl_arrow; ])
let height = Box.draw (Box.hbox [ Box.rotate 90. dbl_arrow; brect ])
end
module Move = struct
let fnstex s = Picture.tex (Format.sprintf "{\\footnotesize %s}" s)
let shift =
let pt = Point.pt (bp 40., bp 25.) in
let vec =
cpic (
seq [Arrow.point_to_point Point.origin pt;
Command.dotlabel ~pos:`Top (fnstex "pt") pt;
Command.dotlabel ~pos:`Bot (fnstex "(0,0)") Point.origin;
]) in
let b = brect in
let b' = Box.shift pt b in
let shift =
cpic ( seq [Box.draw b; Box.draw b';
Arrow.point_to_point (Box.ctr b) (Box.ctr b')])
in
Box.draw (Box.hbox [vec; shift])
let center =
let pt = Point.pt (bp 40., bp 25.) in
let vec =
seq [Arrow.point_to_point Point.origin pt;
Command.dotlabel ~pos:`Top (fnstex "pt") pt; ] in
let b = brect in
let b' = Box.center pt b in
seq [vec; Box.draw b; Box.draw b']
end
module Align = struct
let dist = 20.
let p1 = Point.p (-.dist, dist)
let p2 = Point.sub Point.origin p1
let mkb s = round_rect (tex s)
let a, b , c =
let a = mkb "A" and borig = mkb "B" and corig = mkb "C" in
let b = shift p1 borig in
let c = shift p2 corig in
a, b, c
let all = [a;b;c]
let orig = group all
let sidebyside l =
let b = group l in
let s = hbox ~padding:(Num.bp 50.) [orig; b] in
seq
[ draw s;
Helpers.box_arrow ~sep:(Num.bp 20.) ~within:s ~pen:Pen.circle
~color:Color.red orig b
]
let origfig = draw orig
let halign = sidebyside (halign Num.zero all)
let hplace = sidebyside (hplace all)
let hbox = sidebyside (hbox_list all)
end
let _ = Metapost.emit "circle" Forms.circle
let _ = Metapost.emit "rect" Forms.rect
let _ = Metapost.emit "round_rect" Forms.round_rect
let _ = Metapost.emit "ellipse" Forms.ellipse
let _ = Metapost.emit "patatoid" Forms.patatoid
let _ = Metapost.emit "tex" Forms.tex
let _ = Metapost.emit "ctr" Dirs.ctr
let _ = Metapost.emit "north" Dirs.north
let _ = Metapost.emit "south" Dirs.south
let _ = Metapost.emit "west" Dirs.west
let _ = Metapost.emit "east" Dirs.east
let _ = Metapost.emit "north_west" Dirs.north_west
let _ = Metapost.emit "south_west" Dirs.south_west
let _ = Metapost.emit "north_east" Dirs.north_east
let _ = Metapost.emit "south_east" Dirs.south_east
let _ = Metapost.emit "width" Size.width
let _ = Metapost.emit "height" Size.height
let _ = Metapost.emit "shift" Move.shift
let _ = Metapost.emit "center" Move.center
let _ = Metapost.emit "halign" Align.halign
let _ = Metapost.emit "hplace" Align.hplace
let _ = Metapost.emit "hbox" Align.hbox
let () = Mlpost.Metapost.dump "img_doc"
mlpost-0.8.2/dash.ml 0000664 0000000 0000000 00000002536 13060465153 0014321 0 ustar 00root root 0000000 0000000 (**************************************************************************)
(* *)
(* Copyright (C) Johannes Kanig, Stephane Lescuyer *)
(* Jean-Christophe Filliatre, Romain Bardou and Francois Bobot *)
(* *)
(* This software is free software; you can redistribute it and/or *)
(* modify it under the terms of the GNU Library General Public *)
(* License version 2.1, with the special exception on linking *)
(* described in file LICENSE. *)
(* *)
(* This software is distributed in the hope that it will be useful, *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *)
(* *)
(**************************************************************************)
open Types
type t = Types.dash
type on_off = Types.on_off
let on = mkOn
let off = mkOff
let evenly = mkDEvenly
let withdots = mkDWithdots
let scaled f = mkDScaled f
let shifted = mkDShifted
let pattern = mkDPattern
mlpost-0.8.2/defaults.ml 0000664 0000000 0000000 00000002312 13060465153 0015201 0 ustar 00root root 0000000 0000000 let defaultprelude = "\\documentclass{article}\n"
let default_filename_prefix = ""
let default_required_files : File.t list = []
let default_t1disasm : string option = None
let default_verbosity = false
let default_debug = false
let mk_ref_default x =
let r = ref x in
(fun () -> !r), (fun x -> r := x)
let get_prelude, set_prelude = mk_ref_default defaultprelude
let set_prelude_from_file f =
set_prelude (Metapost_tool.read_prelude_from_tex_file f)
let get_t1disasm, set_t1disasm = mk_ref_default default_t1disasm
let get_filename_prefix, set_filename_prefix =
mk_ref_default default_filename_prefix
let required_files = ref default_required_files
let get_required_files () = ! required_files
let set_required_files l = required_files := List.map File.from_string l
let append_required_file f =
required_files := File.from_string f :: !required_files
let get_verbosity, set_verbosity = mk_ref_default default_verbosity
let get_debug, set_debug = mk_ref_default default_debug
type job = string * Types.commandpic
type jobs = job list
let figures = Queue.create ()
let emit s f =
let s = get_filename_prefix () ^ s in
Queue.add (s, f) figures
let emited () = Queue.fold (fun l t -> t :: l) [] figures
mlpost-0.8.2/defaults.mli 0000664 0000000 0000000 00000001266 13060465153 0015361 0 ustar 00root root 0000000 0000000 val get_prelude : unit -> string
val set_prelude : string -> unit
val set_prelude_from_file : string -> unit
val get_filename_prefix : unit -> string
val set_filename_prefix : string -> unit
val set_required_files : string list -> unit
val get_required_files : unit -> File.t list
val append_required_file : string -> unit
val get_t1disasm : unit -> string option
val set_t1disasm : string option -> unit
val set_verbosity : bool -> unit
val get_verbosity : unit -> bool
val set_debug : bool -> unit
val get_debug : unit -> bool
type job = string * Types.commandpic
type jobs = job list
val figures : job Queue.t
val emit : string -> Types.commandpic -> unit
val emited : unit -> jobs
mlpost-0.8.2/diag.ml 0000664 0000000 0000000 00000011572 13060465153 0014306 0 ustar 00root root 0000000 0000000 (**************************************************************************)
(* *)
(* Copyright (C) Johannes Kanig, Stephane Lescuyer *)
(* Jean-Christophe Filliatre, Romain Bardou and Francois Bobot *)
(* *)
(* This software is free software; you can redistribute it and/or *)
(* modify it under the terms of the GNU Library General Public *)
(* License version 2.1, with the special exception on linking *)
(* described in file LICENSE. *)
(* *)
(* This software is distributed in the hope that it will be useful, *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *)
(* *)
(**************************************************************************)
open Helpers
module Node = struct
type t = {
box_style : (Box.t -> Box.t) option;
id : int;
fill : Color.t option;
boxed: bool option;
x : float;
y : float;
s : Box.t; }
let create =
let c = ref min_int in
fun style fill boxed x y s ->
incr c;
{ box_style = style; id = !c; fill = fill; boxed = boxed;
x = x; y = y; s = s; }
let hash n =
n.id
let equal n1 n2 =
n1.id == n2.id
end
module Hnode = Hashtbl.Make(Node)
open Node
type node = Node.t
let node ?style ?fill ?boxed x y s =
Node.create style fill boxed x y s
type dir = Up | Down | Left | Right | Angle of float
type arrow = {
src : node;
dst : node;
lab : string;
line_width : Num.t option;
boxed:bool;
line_color: Color.t option;
fill_color : Color.t option;
head : bool;
dashed : Types.dash option;
pos : Command.position option;
outd : dir option;
ind : dir option;
}
type t = {
nodes : node list;
boxes : Box.t Hnode.t;
mutable arrows: arrow list;
}
let create l =
{ nodes = l; boxes = Hnode.create 17; arrows = [] }
let arrow d ?(lab="") ?line_width ?(boxed=true) ?line_color ?fill_color
?pos ?(head=true) ?dashed ?outd ?ind n1 n2 =
d.arrows <-
{ src = n1; dst = n2; lab = lab;
line_width = line_width ; boxed = boxed ;
line_color = line_color ; fill_color = fill_color ;
head = head; dashed = dashed;
pos = pos; outd = outd; ind = ind }
:: d.arrows
let outdir = function
| Up -> Path.vec Point.up
| Down -> Path.vec Point.down
| Left -> Path.vec Point.left
| Right -> Path.vec Point.right
| Angle f -> Path.vec (Point.dir f)
let indir = function
| Up -> Path.vec Point.down
| Down -> Path.vec Point.up
| Left -> Path.vec Point.right
| Right -> Path.vec Point.left
| Angle f -> Path.vec (Point.dir f)
let outdir = function None -> None | Some x -> Some (outdir x)
let indir = function None -> None | Some x -> Some (indir x)
type node_style = Box.t -> Box.t
let make_box ?fill ?boxed ~style ~scale d n =
let p = Point.pt (scale n.x, scale n.y) in
let pic = n.s in
let b = match n.box_style with
| None -> style pic
| Some f -> f pic
in
let b = Box.center p b in
let b = match fill with None -> b | Some f -> Box.set_fill f b in
let b = match boxed with
| None -> b
| Some true -> Box.set_stroke Color.black b
| Some false -> Box.clear_stroke b
in
Hnode.add d.boxes n b;
b
let box_of d = Hnode.find d.boxes
let draw_arrow ?stroke ?pen ?dashed d a =
let src = box_of d a.src in
let dst = box_of d a.dst in
match a.line_width with
| None ->
let ba, bla =
if a.head then box_arrow, box_label_arrow
else box_line, box_label_line in
let color = match a.line_color with
| None -> stroke
| Some _ as c -> c in
if a.lab = "" then
ba ?color ?pen ?dashed:a.dashed
?outd:(outdir a.outd) ?ind:(indir a.ind) src dst
else
bla
?color ?pen ?dashed:a.dashed
?outd:(outdir a.outd) ?ind:(indir a.ind)
?pos:a.pos (Picture.tex a.lab) src dst
| Some width ->
let path = Box.cpath ?outd:(outdir a.outd) ?ind:(indir a.ind) src dst in
let src = Path.point 0. path in
let dst = Path.point 1. path in
Arrow.draw_thick ~boxed:a.boxed ?line_color:a.line_color
?fill_color:a.fill_color
?outd:(outdir a.outd) ?ind:(indir a.ind) ~width src dst
let fortybp x = Num.bp (40. *. x)
let defaultbox s = Box.round_rect ~dx:Num.two ~dy:Num.two s
let draw ?(scale=fortybp) ?(style=defaultbox) ?boxed ?fill ?stroke ?pen d =
let l =
List.map
(fun n ->
let fill = if n.fill <> None then n.fill else fill in
let boxed = if n.Node.boxed <> None then n.Node.boxed else boxed in
Box.draw (make_box ?fill ?boxed ~style ~scale d n)) d.nodes
in
Command.seq (l @ List.map (draw_arrow ?stroke ?pen d) d.arrows)
mlpost-0.8.2/duplicate.ml 0000664 0000000 0000000 00000007165 13060465153 0015357 0 ustar 00root root 0000000 0000000 (**************************************************************************)
(* *)
(* Copyright (C) Johannes Kanig, Stephane Lescuyer *)
(* Jean-Christophe Filliatre, Romain Bardou and Francois Bobot *)
(* *)
(* This software is free software; you can redistribute it and/or *)
(* modify it under the terms of the GNU Library General Public *)
(* License version 2.1, with the special exception on linking *)
(* described in file LICENSE. *)
(* *)
(* This software is distributed in the hope that it will be useful, *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *)
(* *)
(**************************************************************************)
open Types
open Hashcons
(* A duplicate analysis - find out the number of times a node is used *)
module MetaPath =
struct
type t = metapath_node hash_consed
let equal = (==)
let hash x = x.hkey
end
module Path =
struct
type t = path_node hash_consed
let equal = (==)
let hash x = x.hkey
end
module Picture =
struct
type t = picture_node hash_consed
let equal = (==)
let hash x = x.hkey
end
module MPthM = Hashtbl.Make (MetaPath)
module PthM = Hashtbl.Make (Path)
module PicM = Hashtbl.Make (Picture)
let path_map = PthM.create 257
let picture_map = PicM.create 257
let test_and_incr_path n =
try incr (PthM.find path_map n); true
with Not_found -> PthM.add path_map n (ref 1); false
let test_and_incr_pic n =
try incr (PicM.find picture_map n); true
with Not_found -> PicM.add picture_map n (ref 1); false
let option_count f = function
| None -> ()
| Some x -> f x
let rec metapath p =
match p.Hashcons.node with
| MPAConcat (k,j,p) -> metapath p
| MPAAppend (p1,j,p2) -> metapath p1; metapath p2
| MPAKnot k -> ()
| MPAofPA p -> path p
and path' = function
| PAofMPA p -> metapath p
| MPACycle (_,_,p) -> metapath p
| PATransformed (p,_) -> path p
| PACutAfter (p1,p2)
| PACutBefore (p1,p2) -> path p1; path p2
| PABuildCycle pl -> List.iter path pl
| PASub (f1, f2, p) -> path p
| PABBox p -> commandpic p
| PAUnitSquare | PAQuarterCircle | PAHalfCircle | PAFullCircle -> ()
and path p =
(* Format.printf "%a@." Print.path p; *)
if test_and_incr_path p then () else path' p.node
and picture' = function
| PITransformed (p,_) -> commandpic p
| PITex s -> ()
| PIClip (pic,pth) -> commandpic pic; path pth
and picture p =
if test_and_incr_pic p then () else picture' p.node
and command c =
match c.node with
| CDraw (p, b) ->
path p; brush b
| CFill (p, c) -> path p
| CDotLabel (pic, _, _) -> commandpic pic
| CLabel (pic, _ ,_) -> commandpic pic
| CExternalImage _ -> ()
and brush b =
let b = b.Hashcons.node in
option_count pen b.pen; option_count dash b.dash
and pen p =
match p.Hashcons.node with
| PenCircle | PenSquare -> ()
| PenFromPath p -> path p
| PenTransformed (p, _) -> pen p
and dash d =
match d.Hashcons.node with
| DEvenly | DWithdots -> ()
| DScaled (f, d) -> dash d
| DShifted (_, d) -> dash d
| DPattern l -> List.iter dash_pattern l
and dash_pattern _ = ()
and commandpic p =
match p.node with
| Picture p -> picture p
| Command c -> command c
| Seq l -> List.iter commandpic l
mlpost-0.8.2/dvi/ 0000775 0000000 0000000 00000000000 13060465153 0013624 5 ustar 00root root 0000000 0000000 mlpost-0.8.2/dvi/Makefile 0000664 0000000 0000000 00000000224 13060465153 0015262 0 ustar 00root root 0000000 0000000 OCAMLBUILD := ocamlbuild -cflag "-dtypes"
all:
$(OCAMLBUILD) dev_save.cmx
clean:
$(OCAMLBUILD) -clean
doc:
$(OCAMLBUILD) dvi.docdir/index.html
mlpost-0.8.2/dvi/_tags 0000664 0000000 0000000 00000000225 13060465153 0014643 0 ustar 00root root 0000000 0000000 or : syntax_bitstring
or : pkg_bitstring, pkg_bitstring.syntax
<*.cmx> : for-pack(Mlpost)
: pkg_cairo mlpost-0.8.2/dvi/dvi.ml 0000664 0000000 0000000 00000052651 13060465153 0014751 0 ustar 00root root 0000000 0000000 (**************************************************************************)
(* *)
(* Copyright (C) Johannes Kanig, Stephane Lescuyer *)
(* Jean-Christophe Filliatre, Romain Bardou and Francois Bobot *)
(* *)
(* This software is free software; you can redistribute it and/or *)
(* modify it under the terms of the GNU Library General Public *)
(* License version 2.1, with the special exception on linking *)
(* described in file LICENSE. *)
(* *)
(* This software is distributed in the hope that it will be useful, *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *)
(* *)
(**************************************************************************)
open Dvi_util
type preamble = {
pre_version : int;
pre_num : int32;
pre_den : int32;
pre_mag : int32;
pre_text : string;
}
type postamble = {
last_page : int32;
post_num : int32;
post_den : int32;
post_mag : int32;
post_height : int32;
post_width : int32;
post_stack : int;
post_pages : int;
}
type postpostamble = {
postamble_pointer : int32;
post_post_version : int;
}
type command =
| SetChar of int32
| SetRule of int32 * int32
| PutChar of int32
| PutRule of int32 * int32
| Push
| Pop
| Right of int32
| Wdefault
| W of int32
| Xdefault
| X of int32
| Down of int32
| Ydefault
| Y of int32
| Zdefault
| Z of int32
| FontNum of int32
| Special of string
type page = {
counters : int32 array;
previous : int32;
commands : command list
}
type fontmap = Dvi_util.font_def Int32Map.t
type t = {
preamble : preamble;
pages : page list;
postamble : postamble;
postpostamble : postpostamble;
font_map : fontmap
}
(* vf *)
type preamble_vf = {
pre_vf_version : int;
pre_vf_text : string;
pre_vf_cs : int32;
pre_vf_ds : float;
}
type char_desc =
{ char_code : int32;
char_tfm : int32;
char_commands : command list}
type vf =
{ vf_preamble : preamble_vf;
vf_font_map : fontmap;
vf_chars_desc : char_desc list}
(* *)
let fontmap d = d.font_map
module Print = struct
open Format
let preamble fmt p =
fprintf fmt "* Preamble :\n";
fprintf fmt "\tversion number = %d\n" p.pre_version;
fprintf fmt "\tnumerator/denominator = %ld/%ld\n"
p.pre_num p.pre_den;
fprintf fmt "\tmagnification = %ld\n" p.pre_mag;
fprintf fmt "\tcomment : %s\n" p.pre_text
let fonts fmt fonts =
fprintf fmt "* Fonts defined in this file :\n";
Int32Map.iter (fun k f -> Print_font.font k fmt f) fonts
let postamble fmt p =
fprintf fmt "* Postamble :\n";
fprintf fmt "\tlast page = %ld\n" p.last_page;
fprintf fmt "\tnumerator/denominator = %ld/%ld\n"
p.post_num p.post_den;
fprintf fmt "\tmagnification = %ld\n" p.post_mag;
fprintf fmt "\theight - width = %ld - %ld\n"
p.post_height p.post_width;
fprintf fmt "\tmaximum stack depth = %d\n" p.post_stack;
fprintf fmt "\ttotal # of pages = %d\n" p.post_pages
let postpostamble fmt p =
fprintf fmt "* Postpostamble :\n";
fprintf fmt "\tPostamble can be found at %ld.\n" p.postamble_pointer;
fprintf fmt "\tDVI version : %d\n" p.post_post_version
let commands fmt = function
| SetChar c ->
Format.fprintf fmt "Setting character %ld.@\n" c
| SetRule(a, b) ->
Format.fprintf fmt "Setting rule (w=%ld, h=%ld).@\n" a b
| PutChar c ->
Format.fprintf fmt "Putting character %ld.@\n" c
| PutRule(a, b) ->
Format.fprintf fmt "Putting rule (w=%ld, h=%ld).@\n" a b
| Push ->
Format.fprintf fmt "Push current state.@\n"
| Pop ->
Format.fprintf fmt "Pop current state.@\n"
| Right b ->
Format.fprintf fmt "Moving right %ld.@\n" b
| Wdefault ->
Format.fprintf fmt "Moving right by the default W.@\n"
| W b ->
Format.fprintf fmt "Moving right and changing W to %ld.@\n" b
| Xdefault ->
Format.fprintf fmt "Moving right by the default X.@\n"
| X b ->
Format.fprintf fmt "Moving right and changing X to %ld.@\n" b
| Down a ->
Format.fprintf fmt "Moving down %ld.@\n" a
| Ydefault ->
Format.fprintf fmt "Moving down by the default Y.@\n"
| Y a ->
Format.fprintf fmt "Moving down and changing Y to %ld.@\n" a
| Zdefault ->
Format.fprintf fmt "Moving down by the default Z.@\n"
| Z a ->
Format.fprintf fmt "Moving down and changing Z to %ld.@\n" a
| FontNum f ->
Format.fprintf fmt "Font is now set to %ld@\n" f
| Special xxx ->
Format.fprintf fmt "Special command : %s@\n" xxx
let print_chars fmt c =
Format.fprintf fmt "@[%ld : %a@]@\n" c.char_code
(Misc.print_list Misc.newline commands) c.char_commands
let print_chars_desc = (Misc.print_list Misc.newline print_chars)
let print_vf fmt vf =
Format.fprintf fmt "cs=%ld ds=%f %s@\n%a@\n%a@\n"
vf.vf_preamble.pre_vf_cs
vf.vf_preamble.pre_vf_ds
vf.vf_preamble.pre_vf_text
fonts vf.vf_font_map
print_chars_desc vf.vf_chars_desc
let page verbose fmt
{counters = c; previous = prev; commands = cmds} =
fprintf fmt "* Page number :";
Array.iter (fun c -> fprintf fmt "%ld;" c) c; fprintf fmt "\n";
fprintf fmt "\tPrevious page can be found at %ld\n" prev;
if verbose then Misc.print_list Misc.newline commands fmt cmds
else fprintf fmt "\t"
let pages verbose fmt =
List.iter (fun p -> fprintf fmt "%a\n" (page verbose) p)
let page_verb = page true
let pages_verb = pages true
let page = page false
let pages = pages false
let doc name fmt doc =
fprintf fmt "***********************\n";
fprintf fmt "Reading DVI file : %s\n" name;
fprintf fmt "%a%a%a%a%a"
preamble doc.preamble pages doc.pages
fonts doc.font_map postamble doc.postamble
postpostamble doc.postpostamble
end
exception DviError of string ;;
let dvi_error s = raise (DviError s)
let preamble bits =
bitmatch bits with
| { 247 : 8; (* Preamble opcode *)
version : 8; (* DVI version *)
num : 32 : bigendian; (* numerator *)
den : 32 : bigendian; (* denominator *)
mag : 32 : bigendian; (* magnification *)
k : 8; (* size of string x *)
x : 8*k : string; (* file comment *)
bits : -1 : bitstring
} ->
{ pre_version = version;
pre_num = num; pre_den = den; pre_mag = mag;
pre_text = x
}, bits
| { _ : -1 : bitstring } ->
dvi_error "Ill-formed preamble"
let add_font k font map =
if Int32Map.mem k map then
dvi_error "Redefinition of font not allowed"
else
Int32Map.add k font map
let font_def bits =
bitmatch bits with
| { checksum : 32 : bigendian; (* checksum of the TMF file *)
scale_factor : 32 : bigendian; (* scale factor *)
design_size : 32 : bigendian; (* design size *)
a : 8; (* size of the area *)
l : 8; (* size of the filename *)
name : (a+l)*8 : string; (* the full name w/ area *)
bits : -1 : bitstring
} ->
mk_font_def ~checksum ~scale_factor ~design_size
~area:(String.sub name 0 a) ~name:(String.sub name a l), bits
| { _ : -1 : bitstring } ->
dvi_error "Ill_formed font definition"
let page_counters bits =
bitmatch bits with
| { c0 : 32 : bigendian;
c1 : 32 : bigendian;
c2 : 32 : bigendian;
c3 : 32 : bigendian;
c4 : 32 : bigendian;
c5 : 32 : bigendian;
c6 : 32 : bigendian;
c7 : 32 : bigendian;
c8 : 32 : bigendian;
c9 : 32 : bigendian;
prev : 32 : bigendian;
bits : -1 : bitstring
} ->
[| c0; c1; c2; c3; c4; c5; c6; c7; c8; c9 |], prev, bits
| { _ : -1 : bitstring } ->
dvi_error "Ill-formed counters after bop"
let signed i j unsigned =
if Int32.zero = Int32.logand unsigned i then
unsigned
else
Int32.logor unsigned j
let signed_8 = signed (Int32.shift_left Int32.one 23)
(Int32.logxor Int32.minus_one (Int32.of_int 0xff))
let signed_16 = signed (Int32.shift_left Int32.one 15)
(Int32.logxor Int32.minus_one (Int32.of_int 0xffff))
let signed_24 = signed (Int32.shift_left Int32.one 23)
(Int32.logxor Int32.minus_one (Int32.of_int 0xffffff))
let command bits =
bitmatch bits with
(* Setting Characters *)
| { k : 8 ; bits : -1 : bitstring } when 0 <= k && k <= 127 ->
SetChar (Int32.of_int k), bits
| { 128 : 8; k : 8; bits : -1 : bitstring } ->
SetChar (Int32.of_int k), bits
| { 129 : 8; k : 16; bits : -1 : bitstring } ->
SetChar (Int32.of_int k), bits
| { 130 : 8; k : 24; bits : -1 : bitstring } ->
SetChar (Int32.of_int k), bits
| { 131 : 8; k : 32; bits : -1 : bitstring } ->
SetChar k, bits
(* Setting a Rule *)
| { 132 : 8; a : 32; b: 32; bits : -1 : bitstring } ->
SetRule(a, b), bits
(* Putting Characters *)
| { 133 : 8; k : 8; bits : -1 : bitstring } ->
PutChar (Int32.of_int k), bits
| { 134 : 8; k : 16; bits : -1 : bitstring } ->
PutChar (Int32.of_int k), bits
| { 135 : 8; k : 24; bits : -1 : bitstring } ->
PutChar (Int32.of_int k), bits
| { 136 : 8; k : 32; bits : -1 : bitstring } ->
PutChar k, bits
(* Putting a Rule *)
| { 137 : 8; a : 32; b: 32; bits : -1 : bitstring } ->
PutRule(a, b), bits
(* Stack operations *)
| { 141 : 8; bits : -1 : bitstring } ->
Push, bits
| { 142 : 8; bits : -1 : bitstring } ->
Pop, bits
(* Moving to the right *)
(* Must be signed but bitstring 2.0.0 fails*)
| { 143 : 8; b : 8 ; bits : -1 : bitstring } ->
Right (signed_8 (Int32.of_int b)), bits
| { 144 : 8; b : 16 ; bits : -1 : bitstring } ->
Right (signed_16 (Int32.of_int b)), bits
| { 145 : 8; b : 24 ; bits : -1 : bitstring } ->
Right (signed_24 (Int32.of_int b)), bits
| { 146 : 8; b : 32 ; bits : -1 : bitstring } ->
Right b, bits
(* Moving/spacing to the right w *)
| { 147 : 8; bits : -1 : bitstring } ->
Wdefault, bits
| { 148 : 8; b : 8; bits : -1 : bitstring } ->
W (signed_8 (Int32.of_int b)), bits
| { 149 : 8; b : 16; bits : -1 : bitstring } ->
W (signed_16 (Int32.of_int b)), bits
| { 150 : 8; b : 24; bits : -1 : bitstring } ->
W (signed_24 (Int32.of_int b)), bits
| { 151 : 8; b : 32; bits : -1 : bitstring } ->
W b, bits
(* Moving/spacing to the right x *)
| { 152 : 8; bits : -1 : bitstring } ->
Xdefault, bits
| { 153 : 8; b : 8; bits : -1 : bitstring } ->
X (signed_8 (Int32.of_int b)), bits
| { 154 : 8; b : 16; bits : -1 : bitstring } ->
X (signed_16 (Int32.of_int b)), bits
| { 155 : 8; b : 24; bits : -1 : bitstring } ->
X (signed_24 (Int32.of_int b)), bits
| { 156 : 8; b : 32; bits : -1 : bitstring } ->
X b, bits
(* Moving down *)
| { 157 : 8; a : 8; bits : -1 : bitstring } ->
Down (signed_8 (Int32.of_int a)), bits
| { 158 : 8; a : 16; bits : -1 : bitstring } ->
Down (signed_16 (Int32.of_int a)), bits
| { 159 : 8; a : 24; bits : -1 : bitstring } ->
Down (signed_24 (Int32.of_int a)), bits
| { 160 : 8; a : 32; bits : -1 : bitstring } ->
Down a, bits
(* Moving/spacing down y *)
| { 161 : 8; bits : -1 : bitstring } ->
Ydefault, bits
| { 162 : 8; a : 8; bits : -1 : bitstring } ->
Y (signed_8 (Int32.of_int a)), bits
| { 163 : 8; a : 16; bits : -1 : bitstring } ->
Y (signed_16 (Int32.of_int a)), bits
| { 164 : 8; a : 24; bits : -1 : bitstring } ->
Y (signed_24 (Int32.of_int a)), bits
| { 165 : 8; a : 32; bits : -1 : bitstring } ->
Y a, bits
(* Moving/spacing down z *)
| { 166 : 8; bits : -1 : bitstring } ->
Zdefault, bits
| { 167 : 8; a : 8; bits : -1 : bitstring } ->
Z (signed_8 (Int32.of_int a)), bits
| { 168 : 8; a : 16; bits : -1 : bitstring } ->
Z (signed_16 (Int32.of_int a)), bits
| { 169 : 8; a : 24; bits : -1 : bitstring } ->
Z (signed_24 (Int32.of_int a)), bits
| { 170 : 8; a : 32; bits : -1 : bitstring } ->
Z a, bits
(* Setting Fonts *)
| { k : 8 ; bits : -1 : bitstring } when 171 <= k && k <= 234 ->
FontNum (Int32.of_int (k-171)), bits
| { 235 : 8; k : 8; bits : -1 : bitstring } ->
FontNum (Int32.of_int k), bits
| { 236 : 8; k : 16; bits : -1 : bitstring } ->
FontNum (Int32.of_int k), bits
| { 237 : 8; k : 24; bits : -1 : bitstring } ->
FontNum (Int32.of_int k), bits
| { 238 : 8; k : 32; bits : -1 : bitstring } ->
FontNum k, bits
(* Special Commands *)
| { 239 : 8; k : 8; x : k * 8 : string; bits : -1 : bitstring } ->
Special x, bits
| { 240 : 8; k : 16; x : k * 8 : string; bits : -1 : bitstring } ->
Special x, bits
| { 241 : 8; k : 24; x : k * 8 : string; bits : -1 : bitstring } ->
Special x, bits
| { 242 : 8; k : 32; x : (Int32.to_int k) * 8 : string;
bits : -1 : bitstring } ->
Special x, bits
| { _ : -1 : bitstring } ->
dvi_error "bad command !"
let rec page commands fonts bits =
bitmatch bits with
| { 140 : 8; bits : -1 : bitstring } -> (* End of page opcode *)
commands, fonts, bits
(* nop opcode *)
| { 138 : 8; bits : -1 : bitstring } ->
page commands fonts bits
(* font definitions *)
| { 243 : 8; k : 8; bits : -1 : bitstring } ->
let font, bits = font_def bits in
page commands (add_font (Int32.of_int k) font fonts) bits
| { 244 : 8; k : 16 : bigendian; bits : -1 : bitstring } ->
let font, bits = font_def bits in
page commands (add_font (Int32.of_int k) font fonts) bits
| { 245 : 8; k : 24 : bigendian; bits : -1 : bitstring } ->
let font, bits = font_def bits in
page commands (add_font (Int32.of_int k) font fonts) bits
| { 246 : 8; k : 32 : bigendian; bits : -1 : bitstring } ->
let font, bits = font_def bits in
page commands (add_font k font fonts) bits
(* normal command *)
| { bits : -1 : bitstring } ->
let cmd, bits = command bits in
page (cmd::commands) fonts bits
let page = page []
let rec pages p fonts bits =
bitmatch bits with
(* nop opcode *)
| { 138 : 8; bits : -1 : bitstring } ->
pages p fonts bits
(* font definitions *)
| { 243 : 8; k : 8; bits : -1 : bitstring } ->
let font, bits = font_def bits in
pages p (add_font (Int32.of_int k) font fonts) bits
| { 244 : 8; k : 16 : bigendian; bits : -1 : bitstring } ->
let font, bits = font_def bits in
pages p (add_font (Int32.of_int k) font fonts) bits
| { 245 : 8; k : 24 : bigendian; bits : -1 : bitstring } ->
let font, bits = font_def bits in
pages p (add_font (Int32.of_int k) font fonts) bits
| { 246 : 8; k : 32 : bigendian; bits : -1 : bitstring } ->
let font, bits = font_def bits in
pages p (add_font k font fonts) bits
(* begin page opcode *)
| { 139 : 8; bits : -1 : bitstring } ->
let counters, previous, bits = page_counters bits in
let cmds, fonts, bits = page fonts bits in
let newp =
{counters = counters; previous = previous; commands = List.rev cmds}
in
(* Pages in reverse order *)
pages (newp::p) fonts bits
| { bits : -1 : bitstring } ->
p, fonts, bits
(* dvi_error "Expected : nop, font_definition, or new page" *)
let read_pages = pages []
let postamble bits =
let rec skip_font_defs bits =
bitmatch bits with
(* nop opcode *)
| { 138 : 8; bits : -1 : bitstring } ->
skip_font_defs bits
(* font definitions *)
| { 243 : 8; k : 8; bits : -1 : bitstring } ->
let _, bits = font_def bits in skip_font_defs bits
| { 244 : 8; k : 16 : bigendian; bits : -1 : bitstring } ->
let _, bits = font_def bits in skip_font_defs bits
| { 245 : 8; k : 24 : bigendian; bits : -1 : bitstring } ->
let _, bits = font_def bits in skip_font_defs bits
| { 246 : 8; k : 32 : bigendian; bits : -1 : bitstring } ->
let _, bits = font_def bits in skip_font_defs bits
| { bits : -1 : bitstring } ->
bits
in
bitmatch bits with
| { 248 : 8; (* Postamble opcode *)
last_page : 32 : bigendian; (* DVI version *)
num : 32 : bigendian; (* numerator *)
den : 32 : bigendian; (* denominator *)
mag : 32 : bigendian; (* magnification *)
height : 32 : bigendian; (* tallest page *)
width : 32 : bigendian; (* widest page *)
stack : 16 : bigendian; (* stack depth *)
pages : 16 : bigendian; (* number of pages *)
bits : -1 : bitstring
} ->
{ last_page = last_page;
post_num = num; post_den = den; post_mag = mag;
post_height = height; post_width = width;
post_stack = stack; post_pages = pages
}, skip_font_defs bits
| { _ : -1 : bitstring } ->
dvi_error "Ill-formed postamble"
let postpostamble bits =
let rec read_223 bits =
bitmatch bits with
| { 223 : 8;
rest : -1 : bitstring
} ->
read_223 rest
| { rest : -1 : bitstring } ->
if Bitstring.bitstring_length rest = 0 then ()
else dvi_error "Ill-formed suffix : only 223 expected."
in
bitmatch bits with
| { 249 : 8;
postamble_pointer : 32 : bigendian;
version : 8;
rest : -1 : bitstring
} ->
read_223 rest;
{ postamble_pointer = postamble_pointer;
post_post_version = version
}
| { _ : -1 : bitstring } ->
dvi_error "ill-formed postpostamble"
let read_file file =
let bits = Bitstring.bitstring_of_file file in
let preamble, bits = preamble bits in
let pages, fonts, bits = read_pages Int32Map.empty bits in
let postamble, bits = postamble bits in
let postpostamble = postpostamble bits in
{ preamble = preamble;
pages = List.rev pages;
postamble = postamble;
postpostamble = postpostamble;
font_map = fonts
}
let vf_preamble bits =
bitmatch bits with
| { 247 : 8; (* Preamble opcode *)
version : 8; (* VF version *)
k : 8; (* size of string x *)
x : 8*k : string; (* file comment *)
cs : 32 : bigendian; (* denominator *)
ds : 32 : bigendian; (* magnification *)
bits : -1 : bitstring
} ->
{ pre_vf_version = version;
pre_vf_text = x;
pre_vf_cs = cs;
pre_vf_ds = (Int32.to_float ds) /. (2.**20.)
}, bits
| { _ : -1 : bitstring } ->
dvi_error "Ill-formed preamble"
(* Could factor the code with the one of page?*)
let rec preamble_fonts fonts bits =
bitmatch bits with
(* font definitions *)
| { 243 : 8; k : 8; bits : -1 : bitstring } ->
let font, bits = font_def bits in
preamble_fonts (add_font (Int32.of_int k) font fonts) bits
| { 244 : 8; k : 16 : bigendian; bits : -1 : bitstring } ->
let font, bits = font_def bits in
preamble_fonts (add_font (Int32.of_int k) font fonts) bits
| { 245 : 8; k : 24 : bigendian; bits : -1 : bitstring } ->
let font, bits = font_def bits in
preamble_fonts (add_font (Int32.of_int k) font fonts) bits
| { 246 : 8; k : 32 : bigendian; bits : -1 : bitstring } ->
let font, bits = font_def bits in
preamble_fonts (add_font k font fonts) bits
| { bits : -1 : bitstring } ->
fonts,bits
let rec command_list cmds bits =
if Bitstring.bitstring_length bits = 0 then cmds
else let cmd,bits = command bits in
command_list (cmd::cmds) bits
let rec vf_chars chars bits =
bitmatch bits with
| {248 : 8} -> chars
| {242 : 8;
pl : 32;
cc : 32;
tfm : 32;
_ : (Int32.to_int pl)*8 : bitstring;
bits : -1 : bitstring
} ->
let char = { char_code = cc;
char_tfm = tfm;
char_commands = []} in
vf_chars (char::chars) bits
| {pl : 8;
cc : 8;
tfm : 24;
coms : pl*8 : bitstring;
bits : -1 : bitstring
} ->
let coms = List.rev (command_list [] coms) in
let char = { char_code = Int32.of_int cc;
char_tfm = Int32.of_int tfm;
char_commands = coms} in
vf_chars (char::chars) bits
| {i : 8} -> dvi_error "vf : ill-formed character"
let print_vf = Print.print_vf
let read_vf_file file =
let bits = Bitstring.bitstring_of_file file in
let preamble, bits = vf_preamble bits in
let fonts, bits = preamble_fonts Int32Map.empty bits in
let chars_desc = List.rev (vf_chars [] bits) in
{vf_preamble = preamble;
vf_font_map = fonts;
vf_chars_desc = chars_desc}
let get_conv_from_preamble p =
let formule_magique_cm mag num den =
((Int32.to_float mag) *.
((Int32.to_float num) /. (Int32.to_float den))) /. (10.**8.) in
formule_magique_cm p.pre_mag p.pre_num p.pre_den
let get_conv doc = get_conv_from_preamble doc.preamble
let get_height_cm doc =
(get_conv doc) *. (Int32.to_float doc.postamble.post_height)
let get_width_cm doc =
(get_conv doc) *. (Int32.to_float doc.postamble.post_width)
let pages d = d.pages
let commands p = p.commands
module Incremental = struct
type t =
{ mutable fonts : fontmap;
mutable preamble : preamble;
chan : in_channel;
mutable bits : string * int * int;
}
let mk_t c =
let bits = Bitstring.bitstring_of_chan c in
let preamble, bits = preamble bits in
let pgs, fonts, bits = read_pages Int32Map.empty bits in
{ fonts = fonts ; preamble = preamble ; bits = bits; chan = c }, pgs
let next_pages t =
let nextbits = Bitstring.bitstring_of_chan t.chan in
let pgs, fonts, bits =
read_pages t.fonts (Bitstring.concat [t.bits; nextbits]) in
t.fonts <- fonts; t.bits <- bits;
pgs
let get_conv i = get_conv_from_preamble i.preamble
let font_map i = i.fonts
end
mlpost-0.8.2/dvi/dvi.mli 0000664 0000000 0000000 00000005131 13060465153 0015111 0 ustar 00root root 0000000 0000000 (** Low-level DVI interface *)
(** The DVI preamble *)
type preamble = {
pre_version : int;
pre_num : int32;
pre_den : int32;
pre_mag : int32;
pre_text : string;
}
(** The DVI postamble *)
type postamble = {
last_page : int32;
post_num : int32;
post_den : int32;
post_mag : int32;
post_height : int32;
post_width : int32;
post_stack : int;
post_pages : int;
}
(** The DVI postpostamble *)
type postpostamble = {
postamble_pointer : int32;
post_post_version : int;
}
(** The type of commands. All coordinates in this type are relative to the
current state of the DVI document. *)
type command =
| SetChar of int32
| SetRule of int32 * int32
| PutChar of int32
| PutRule of int32 * int32
| Push
| Pop
| Right of int32
| Wdefault
| W of int32
| Xdefault
| X of int32
| Down of int32
| Ydefault
| Y of int32
| Zdefault
| Z of int32
| FontNum of int32
| Special of string
(** A page is a list of commands *)
type page = {
counters : int32 array;
previous : int32;
commands : command list
}
type fontmap = Dvi_util.font_def Dvi_util.Int32Map.t
(** A document is a list of pages, plus a preamble, postamble,
postpostamble and font map *)
type t = {
preamble : preamble;
pages : page list;
postamble : postamble;
postpostamble : postpostamble;
font_map : fontmap
}
(** a few accessor functions *)
val get_conv : t -> float
val fontmap : t -> fontmap
val commands : page -> command list
val pages : t -> page list
val read_file : string -> t
val get_height_cm : t -> float
val get_width_cm : t -> float
(** Vf files *)
(* Vf type *)
type preamble_vf = {
pre_vf_version : int;
pre_vf_text : string;
pre_vf_cs : int32;
pre_vf_ds : float;
}
type char_desc =
{ char_code : int32;
char_tfm : int32;
char_commands : command list}
type vf =
{ vf_preamble : preamble_vf;
vf_font_map : fontmap;
vf_chars_desc : char_desc list}
val print_vf : Format.formatter -> vf -> unit
val read_vf_file : string -> vf
module Incremental : sig
(** Useful to read a DVI file page per page *)
type t
(** The type that stores information regarding the DVI file *)
(* val mk_t : in_channel -> t *)
val mk_t : in_channel -> t * page list
val next_pages : t -> page list
(** read all available pages *)
val get_conv : t -> float
val font_map : t -> fontmap
end
module Print : sig
val page : Format.formatter -> page -> unit
val pages : Format.formatter -> page list -> unit
val page_verb : Format.formatter -> page -> unit
val pages_verb : Format.formatter -> page list -> unit
end
mlpost-0.8.2/dvi/dvi.odocl 0000664 0000000 0000000 00000000050 13060465153 0015423 0 ustar 00root root 0000000 0000000 Dvi
Dviinterp
Dev_save
Fonts
Metric
Tfm
mlpost-0.8.2/dvi/dvi_util.ml 0000664 0000000 0000000 00000002344 13060465153 0016000 0 ustar 00root root 0000000 0000000
module Int32 = struct
include Int32
let hash = to_int
let equal x y = compare x y = 0
end
module Int32Map = Map.Make(Int32)
module Int32H = Hashtbl.Make(Int32)
type font_def = {
checksum : int32;
scale_factor : int32;
design_size : int32;
area : string;
name : string;
}
let mk_font_def ~checksum ~scale_factor ~design_size ~area ~name =
{ checksum = checksum ;
scale_factor = scale_factor ;
design_size = design_size ;
area = area ;
name = name
}
module Print_font = struct
open Format
let print_option pr ff = function
|None -> fprintf ff "None"
|Some a -> pr ff a
let font_map ff font =
fprintf ff "Tex:%s Human:%s Slant:%a Extend:%a Enc:%a Pfab:%s@."
font.Fonts_type.tex_name
font.Fonts_type.human_name
(print_option pp_print_float) font.Fonts_type.slant
(print_option pp_print_float) font.Fonts_type.extend
(print_option pp_print_string) font.Fonts_type.enc_name
font.Fonts_type.pfab_name
let font k fmt f =
fprintf fmt "\tFont number %ld (%s in directory [%s]) :\n"
k f.name f.area;
fprintf fmt "\t Checksum = %lx\n" f.checksum;
fprintf fmt "\t Scale factor / Design size : %ld / %ld\n"
f.scale_factor f.design_size
end
mlpost-0.8.2/dvi/dviinterp.ml 0000664 0000000 0000000 00000031450 13060465153 0016165 0 ustar 00root root 0000000 0000000 (**************************************************************************)
(* *)
(* Copyright (C) Johannes Kanig, Stephane Lescuyer *)
(* Jean-Christophe Filliatre, Romain Bardou and Francois Bobot *)
(* *)
(* This software is free software; you can redistribute it and/or *)
(* modify it under the terms of the GNU Library General Public *)
(* License version 2.1, with the special exception on linking *)
(* described in file LICENSE. *)
(* *)
(* This software is distributed in the hope that it will be useful, *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *)
(* *)
(**************************************************************************)
open Format
open Dvi_util
open Fonts
type color =
| RGB of float * float * float
| CMYK of float * float * float * float
| HSB of float * float * float
| Gray of float
(* a state can be pushed/ popped *)
type state = {
h : int32;
v : int32;
w : int32;
x : int32;
y : int32;
z : int32;
}
(* text *)
type env_info = {ei_conv : float;
ei_pos : int32 * int32}
type info = {
color : color
}
type text =
{ tex_font : Fonts.t;
tex_string : Int32.t list;
tex_pos : float * float;
tex_info : info;
tex_env : env_info}
type text_type1 =
{ c_glyph : Int32.t;
c_font : Fonts.type1;
c_pos : float * float;
c_info : info}
type command =
| Fill_rect of info * float * float * float * float
(** [Fill_rect info x y w h] should draw a rectangle at [(x,y)] of
width [w] and height [h]. *)
| Draw_text of text
| Specials of info * string * float * float
(** [Specials info s x y] should draw special [s], encoded as a string,
at pos. [(x,y)]. [info] can contain additional information
such as color. *)
| Draw_text_type1 of text_type1
(** Can appear only after a decomposition of text *)
type page = command list
type env = {
mutable ecolor : color;
color_stack : color Stack.t;
conv : float;
mutable font : Int32.t;
stack : state Stack.t;
mutable s : state;
use_type1 : bool;
}
let info_of_env env = {color = env.ecolor}
let new_env conv use_type1 = {ecolor = Gray 0.;
conv = conv;
font = Int32.zero;
stack = Stack.create ();
s = {h=Int32.zero; v=Int32.zero;
w=Int32.zero; x=Int32.zero;
y=Int32.zero; z=Int32.zero;
};
color_stack = Stack.create ();
use_type1 = use_type1;
}
let rec scanf_with s def = function
| [] -> def s
| a::l -> try a s
with Scanf.Scan_failure _ | Failure _ | End_of_file
-> scanf_with s def l
let print_state fmt s =
fprintf fmt "{h = %ld; v = %ld; w = %ld; x = %ld; y = %ld; z= %ld}@."
s.h s.v s.w s.x s.y s.z
let put_rule env cmds a b =
let x = env.conv *. (Int32.to_float env.s.h)
and y = env.conv *. (Int32.to_float env.s.v)
and w = env.conv *. (Int32.to_float b)
and h = env.conv *. (Int32.to_float a) in
(Fill_rect (info_of_env env,x,(y -. h),w,h))::cmds
let load_fonts font_map conv =
if Defaults.get_debug () then printf "conv : %f@." conv;
Int32Map.fold (fun k fdef ->
Int32Map.add k (Fonts.load_font fdef conv)
)
font_map Int32Map.empty
let set_env_char (_,font,_) (h,v) c =
begin
if Defaults.get_debug () then
printf "Setting character %ld at (%ld,%ld).@." c h v;
let fwidth = Fonts.char_width font (Int32.to_int c) in
let width = Int32.of_float fwidth in
(Int32.add h width,v)
end
let rec put_char_type1 (info,font,conv) char (h,v) cmds =
match glyphs font with
| VirtualFont vf ->
(* FixMe how to use vf_design_size?
Hack use the one of the first dvi, wrong!!*)
if Defaults.get_debug () then printf "VirtualFont : %s ds=%f conv=%f@."
(Fonts.tex_name font) vf.vf_design_size conv;
let conv = (* vf.vf_design_size *)conv in
let env = new_env conv true in
env.s <- {env.s with h = h; v = v};
(* FIXME design size, font_scale,... All is messed up... :( *)
let fm = load_fonts vf.vf_font_map
(conv (* for palatino (vf?)*) *. 0.65 (* experimental :( *)) in
let l = try Int32H.find vf.vf_chars char
with Not_found -> failwith ("virtual font not found") in
interp_command fm env cmds l
| Type1 font1 ->
let x = conv *. (Int32.to_float h)
and y = conv *. (Int32.to_float v) in
if Defaults.get_debug () then printf "Type1 : %s,%ld,%f,%f@."
(Fonts.tex_name font) char x y;
let text_type1 = { c_glyph = char;
c_font = font1;
c_pos = x,y;
c_info = info} in
Draw_text_type1 text_type1::cmds
and put_text (info,font,conv) scl ((h,v) as pos) cmds =
let x = conv *. (Int32.to_float h)
and y = conv *. (Int32.to_float v) in
let text = {tex_font = font;
tex_string = List.rev scl;
tex_pos = (x,y);
tex_info = info;
tex_env = {ei_conv = conv; ei_pos = pos}} in
Draw_text text::cmds
and set_char fm env cmds l =
let info = (info_of_env env) in
let font = Int32Map.find env.font fm in
let conv = env.conv in
let ifc = (info,font,conv) in
let pos = (env.s.h,env.s.v) in
let cmds,(h,v),l = if env.use_type1 then set_char_type1 ifc pos cmds l
else set_char_tex ifc [] pos pos cmds l in
env.s <- {env.s with h = h; v = v};
interp_command fm env cmds l
and set_char_type1 ifc pos cmds l =
match l with
| Dvi.SetChar c::l ->
let cmds = put_char_type1 ifc c pos cmds in
let pos = set_env_char ifc pos c in
cmds, pos, l
| Dvi.PutChar c::l ->
if Defaults.get_debug () then printf "Putting character %ld.@." c;
let cmds = put_char_type1 ifc c pos cmds in
cmds, pos, l
| _ -> assert false
and set_char_tex ifc scl pos_start pos_end cmds
(l : Dvi.command list) =
match l with
| Dvi.SetChar c::l ->
let pos_end = set_env_char ifc pos_end c in
set_char_tex ifc (c::scl) pos_start pos_end cmds l
| Dvi.PutChar c::l ->
if Defaults.get_debug () then printf "Putting character %ld.@." c;
close_string ifc (c::scl) pos_start pos_end cmds l
| l -> close_string ifc scl pos_start pos_end cmds l
and close_string ifc scl pos_start pos_end cmds l =
let cmds = put_text ifc scl pos_start cmds in
cmds,pos_end,l
and interp_command fm env cmds l =
match l with
| [] -> cmds
| (Dvi.SetChar _ | Dvi.PutChar _)::_ ->
set_char fm env cmds l
| Dvi.SetRule(a, b)::l ->
if Defaults.get_debug () then printf "Setting rule (w=%ld, h=%ld).@." a b;
let cmds = put_rule env cmds a b in
env.s <- {env.s with h = Int32.add env.s.h b};
interp_command fm env cmds l
| Dvi.PutRule(a, b)::l ->
if Defaults.get_debug () then printf "Putting rule (w=%ld, h=%ld).@." a b;
let cmds = put_rule env cmds a b in
interp_command fm env cmds l
| Dvi.Push::l ->
if Defaults.get_debug () then printf "Push current state.@.";
Stack.push env.s env.stack;
interp_command fm env cmds l
| Dvi.Pop::l ->
(try
if Defaults.get_debug () then printf "Pop current state.@.";
env.s <- Stack.pop env.stack
with Stack.Empty -> failwith "Empty color stack !");
interp_command fm env cmds l
| Dvi.Right b::l ->
if Defaults.get_debug () then printf "Moving right %ld.@." b;
env.s<-{env.s with h = Int32.add env.s.h b};
interp_command fm env cmds l
| Dvi.Wdefault::l ->
if Defaults.get_debug () then printf "Moving right by the default W.@.";
env.s<-{env.s with h = Int32.add env.s.h env.s.w};
interp_command fm env cmds l
| Dvi.W b::l ->
if Defaults.get_debug () then printf "Moving right and changing W to %ld.@." b;
env.s<-{env.s with h = Int32.add env.s.h b; w = b};
interp_command fm env cmds l
| Dvi.Xdefault::l ->
if Defaults.get_debug () then printf "Moving right by the default X.@.";
env.s<-{env.s with h = Int32.add env.s.h env.s.x};
interp_command fm env cmds l
| Dvi.X b::l ->
if Defaults.get_debug () then printf "Moving right and changing X to %ld.@." b;
env.s<-{env.s with h = Int32.add env.s.h b; x = b};
interp_command fm env cmds l
| Dvi.Down a::l ->
if Defaults.get_debug () then printf "Moving down %ld.@." a;
env.s <- {env.s with v = Int32.add env.s.v a};
interp_command fm env cmds l
| Dvi.Ydefault::l ->
if Defaults.get_debug () then printf "Moving down by the default Y.@.";
env.s <- {env.s with v = Int32.add env.s.v env.s.y};
interp_command fm env cmds l
| Dvi.Y a::l ->
if Defaults.get_debug () then printf "Moving down and changing Y to %ld.@." a;
env.s <- {env.s with v = Int32.add env.s.v a; y = a};
interp_command fm env cmds l
| Dvi.Zdefault::l ->
if Defaults.get_debug () then printf "Moving down by the default Z.@.";
env.s <- {env.s with v = Int32.add env.s.v env.s.z};
interp_command fm env cmds l
| Dvi.Z a::l ->
if Defaults.get_debug () then printf "Moving down and changing Z to %ld.@." a;
env.s <- {env.s with v = Int32.add env.s.v a; z = a};
interp_command fm env cmds l
| Dvi.FontNum f::l ->
env.font <- f;
if Defaults.get_debug () then printf "Font is now set to %ld@." f;
interp_command fm env cmds l
| Dvi.Special xxx::l ->
if Defaults.get_debug () then printf "Special command : %s@." xxx;
let x = env.conv *. (Int32.to_float env.s.h)
and y = env.conv *. (Int32.to_float env.s.v) in
let push color =
Stack.push env.ecolor env.color_stack;
env.ecolor <- color;
cmds in
let cmds = scanf_with
xxx
(fun s -> Specials (info_of_env env,s,x,y)::cmds)
[(fun s -> Scanf.sscanf s "color push rgb %f %f %f"
(fun r g b -> push (RGB (r,g,b))));
(fun s -> Scanf.sscanf s "color push cmyk %f %f %f %f"
(fun c m y k -> push (CMYK(c,m,y,k))));
(fun s -> Scanf.sscanf s "color push gray %f"
(fun g -> push (Gray(g))));
(fun s -> Scanf.sscanf s "color push hsb %f %f %f"
(fun h s b -> push (HSB(h,s,b))));
(fun s -> Scanf.sscanf s "color pop%n"
(fun _ -> env.ecolor <-
(* todo : color stack seems to traverse pages and so pop before push in one page *)
try Stack.pop env.color_stack
with Stack.Empty -> failwith "Empty color stack !");cmds);] in
interp_command fm env cmds l
let interp_page conv fm p =
interp_command fm (new_env conv false) [] (Dvi.commands p)
let load_doc doc =
let conv = Dvi.get_conv doc in
let fonts = load_fonts (Dvi.fontmap doc) conv in
let pages = List.fold_left (fun acc p ->
if Defaults.get_debug () then
printf "#### Starting New Page ####@."
else if Defaults.get_verbosity () then printf ".";
(interp_page conv fonts p)::acc)
[] (Dvi.pages doc) in
List.rev pages
let load_file file =
let doc = Dvi.read_file (File.to_string file) in
if Defaults.get_verbosity () then
printf "Dvi file parsing and interpretation :@.@?";
let res = load_doc doc in
if Defaults.get_verbosity () then
printf " done@.@?";
res
let decompose_text text =
let font = text.tex_font in
let pos = text.tex_env.ei_pos in
if Defaults.get_debug () then
printf "decompose text at (%ld,%ld)@." (fst pos) (snd pos);
let info = text.tex_info in
let ifc = (info,font,text.tex_env.ei_conv) in
let fold (pos,cmds) c =
let cmds = put_char_type1 ifc c pos cmds in
(set_env_char ifc pos c,cmds) in
let _,cmds = List.fold_left fold (pos,[]) text.tex_string in
cmds
module Incremental = struct
let load_page i p =
let conv = Dvi.Incremental.get_conv i in
let fonts = load_fonts (Dvi.Incremental.font_map i) conv in
interp_page conv fonts p
end
module Print = struct
(* debug printing *)
open Format
let command fmt c =
match c with
| Fill_rect (_,x,y,w,h) -> fprintf fmt "rect(%f,%f,%f,%f)" x y w h
| Draw_text text -> fprintf fmt "glyph (%s)" (Fonts.tex_name text.tex_font)
| Specials _ -> assert false
| Draw_text_type1 _ -> assert false
let page fmt p =
fprintf fmt "[< %a >]" (Misc.print_list Misc.newline command) p
let dvi fmt d =
Misc.print_list (fun fmt () ->
fprintf fmt "@\n@\n") page fmt d
end
mlpost-0.8.2/dvi/dviinterp.mli 0000664 0000000 0000000 00000003644 13060465153 0016342 0 ustar 00root root 0000000 0000000 (** This module provides a functor to read DVI files *)
(** The type of colors in a DVI file *)
type color =
| RGB of float * float * float
| CMYK of float * float * float * float
| HSB of float * float * float
| Gray of float
(** The info type *)
type info = {
color : color
}
(* A device can choose the way it want to see a text :
- A string in some tex font at some position
- A list of glyph of some type1 font each at his own position
*)
type env_info
type text =
{ tex_font : Fonts.t;
tex_string : Int32.t list;
tex_pos : float * float;
tex_info : info;
tex_env : env_info}
type text_type1 =
{ c_glyph : Int32.t;
c_font : Fonts.type1;
c_pos : float * float;
c_info : info}
type command =
| Fill_rect of info * float * float * float * float
(** [Fill_rect info x y w h] should draw a rectangle at [(x,y)] of
width [w] and height [h]. *)
| Draw_text of text
| Specials of info * string * float * float
(** [Specials info s x y] should draw special [s], encoded as a string,
at pos. [(x,y)]. [info] can contain additional information
such as color. *)
| Draw_text_type1 of text_type1
(** Can appear only after a decomposition of text *)
type page = command list
val load_file : File.t -> page list
(** [load_file arg fn] loads the dvi document in file [fn], passes
[arg] and the loaded document to {!Dev.new_document} and calls the
drawing functions of {!Dev} as needed. At the end, the return
value of the device is returned. The command list are
in reverse order inside a page*)
val decompose_text : text -> command list
module Incremental : sig
val load_page : Dvi.Incremental.t -> Dvi.page -> page
end
module Print : sig
(* debug printing *)
val command : Format.formatter -> command -> unit
val page : Format.formatter -> page -> unit
val dvi : Format.formatter -> page list -> unit
end
mlpost-0.8.2/dvi/fonts.ml 0000664 0000000 0000000 00000021275 13060465153 0015316 0 ustar 00root root 0000000 0000000 (**************************************************************************)
(* *)
(* Copyright (C) Johannes Kanig, Stephane Lescuyer *)
(* Jean-Christophe Filliatre, Romain Bardou and Francois Bobot *)
(* *)
(* This software is free software; you can redistribute it and/or *)
(* modify it under the terms of the GNU Library General Public *)
(* License version 2.1, with the special exception on linking *)
(* described in file LICENSE. *)
(* *)
(* This software is distributed in the hope that it will be useful, *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *)
(* *)
(**************************************************************************)
open Dvi_util
exception Fonterror of string
let font_error s = raise (Fonterror s)
type type1 =
{ glyphs_tag : int;
(* That must be separated from cairo *)
glyphs_ft : Cairo_ft.ft_face;
(* the file, pfb or pfa, which define the glyphs *)
glyphs_enc : int -> int; (* the conversion of the characters
between tex and the font *)
slant : float option;
extend : float option;
glyphs_ratio_cm : float}
type vf =
{ vf_design_size : float;
vf_font_map : Dvi_util.font_def Dvi_util.Int32Map.t;
vf_chars : Dvi.command list Int32H.t}
type glyphs =
| Type1 of type1
| VirtualFont of vf
type t =
{ tex_name : string;
metric : Tfm.t;
glyphs : glyphs Lazy.t;
ratio : float;
ratio_cm : float
}
let tex_name t = t.tex_name
let ratio_cm t = t.ratio_cm
let metric t = t.metric
let design_size t = Tfm.design_size t.metric
let glyphs t = Lazy.force t.glyphs
let scale t f = t.ratio_cm *. f
let kwhich = "kpsewhich"
let which_fonts_table = "pdftex.map"
let memoize f nb =
let memoize = Hashtbl.create nb in
fun arg ->
try
Hashtbl.find memoize arg
with
Not_found ->
let result = f arg in
Hashtbl.add memoize arg result;
result
let find_file_aux file =
let temp_fn = Filename.temp_file "font_path" "" in
let exit_status =
Sys.command
(Format.sprintf "%s %s > %s" kwhich file temp_fn) in
if exit_status <> 0 then
begin
Sys.remove temp_fn;
font_error "kwhich failed"
end
else
let cin = open_in temp_fn in
let n =
try input_line cin
with _ ->
close_in cin; Sys.remove temp_fn; font_error "Cannot find font"
in
close_in cin; Sys.remove temp_fn; n
let find_file = memoize find_file_aux 30
module HString = Hashtbl
let deal_with_error ?(pfb=false) lexbuf f =
try f ()
with
| (Parsing.Parse_error |Failure _) as a->
let p_start = Lexing.lexeme_start_p lexbuf in
let p_end = Lexing.lexeme_end_p lexbuf in
let str =
if not pfb then "" else
match !Pfb_lexer.state with
| Pfb_lexer.Header -> "header"
| Pfb_lexer.Encoding -> "encoding"
| Pfb_lexer.Charstring -> "charstring" in
Format.eprintf "line %i, characters %i-%i : %s parse_error state : %s@."
p_start.Lexing.pos_lnum p_start.Lexing.pos_bol p_end.Lexing.pos_bol
(Lexing.lexeme lexbuf) str ;
raise a
let load_fonts_map filename =
if Defaults.get_verbosity () then
Format.printf "Load font map from %s...@?" filename;
let file = open_in filename in
let lexbuf = Lexing.from_channel file in
deal_with_error lexbuf (fun () ->
let result = Map_parser.pdftex_main Map_lexer.pdftex_token lexbuf in
let table = HString.create 1500 in
List.iter (fun x -> HString.add table x.Fonts_type.tex_name x) result;
if Defaults.get_verbosity () then Format.printf "done@.";
table)
let load_enc_aux filename =
if Defaults.get_verbosity () then
Format.printf "Loading enc from %s...@?" filename;
let file = open_in filename in
let lexbuf = Lexing.from_channel file in
deal_with_error lexbuf (fun () ->
let result = Pfb_parser.enc_main Pfb_lexer.enc_token lexbuf in
let enc_table = Array.create 256 "" in
let count = ref 0 in
List.iter (fun x -> enc_table.(!count)<-x;incr(count)) result;
if Defaults.get_verbosity () then Format.printf "done@.";
enc_table)
let load_enc = memoize load_enc_aux 15
let fonts_map_table = lazy (load_fonts_map (find_file which_fonts_table))
let fonts_table = (HString.create 1500 : (string,t) Hashtbl.t)
let load_font_tfm fd =
if Defaults.get_verbosity () then
Format.printf "Loading font %s at [%ld/%ld]...@?"
fd.name fd.scale_factor fd.design_size;
let filename =
if fd.area <> "" then
Filename.concat fd.area fd.name
else
find_file (fd.name^".tfm") in
if Defaults.get_debug () then
Format.printf "Trying to find metrics at %s...@." filename;
let tfm = Tfm.read_file filename in
(* FixMe in vf file the checksum of tfm is 0 *)
if (Int32.compare fd.checksum Int32.zero <> 0 &&
Int32.compare tfm.Tfm.body.Tfm.header.Tfm.checksum
fd.checksum <> 0) then
font_error "Metrics checksum do not match !.@.";
if Defaults.get_debug () then
Format.printf "Metrics successfully loaded for font %s from %s.@."
fd.name filename;
if Defaults.get_verbosity () then
Format.printf "done@.";
tfm
let compute_trans_enc encoding_table font_ft char =
let char_name = encoding_table.(char) in
Mlpost_ft.ft_get_name_index font_ft char_name
let font_is_virtual s =
try
Some (find_file (s^".vf"))
with Fonterror _ -> None
let id = let c = ref (-1) in fun () -> incr c; !c
let ft = lazy (Cairo_ft.init_freetype ())
let load_glyphs tex_name ratio_cm =
match font_is_virtual tex_name with
| Some vf ->
let vf = Dvi.read_vf_file vf in
let vf_chars = Int32H.create 257 in
let add cd = Int32H.add vf_chars cd.Dvi.char_code cd.Dvi.char_commands in
List.iter add vf.Dvi.vf_chars_desc;
VirtualFont { vf_design_size = vf.Dvi.vf_preamble.Dvi.pre_vf_ds;
vf_font_map = vf.Dvi.vf_font_map;
vf_chars = vf_chars}
| None ->
let font_map = try HString.find (Lazy.force fonts_map_table) tex_name
with Not_found ->
invalid_arg
(Format.sprintf "This tex font : %s has no pfb counterpart@ \
and seems not to be virtual@ \
it can't be currently used with the cairo backend"
tex_name) in
let pfab = find_file font_map.Fonts_type.pfab_name in
let pfab = Cairo_ft.new_face (Lazy.force ft) pfab in
let glyphs_enc =
match font_map.Fonts_type.enc_name with
| None ->
(* 0 seems to be an empty one,
1 the one in the pfb, but I'm not sure*)
let charmap_index = 1 in
Mlpost_ft.ft_set_charmap pfab charmap_index;
Mlpost_ft.ft_get_char_index pfab
| Some x -> let enc = load_enc (find_file x) in
compute_trans_enc enc pfab in
(* let glyphs_enc i = *)
(* let r = glyphs_enc i in *)
(* Printf.printf "char : %i -> %i\n%!" i r; *)
(* r in *)
Type1 { glyphs_tag = id ();
glyphs_ft = pfab;
glyphs_enc = glyphs_enc;
slant = font_map.Fonts_type.slant;
extend = font_map.Fonts_type.extend;
glyphs_ratio_cm = ratio_cm}
let load_font doc_conv fdef =
let tex_name = fdef.name in
let tfm = load_font_tfm fdef in
let ratio = Int32.to_float fdef.scale_factor
(*(Int32.to_float (Int32.mul mag fdef.Dvi.scale_factor))
/. 1000. (* fdef.Dvi.design_size *)*)
and ratio_cm =
(Int32.to_float fdef.scale_factor) *. doc_conv
in
let glyphs = lazy (load_glyphs tex_name ratio_cm) in
{ tex_name = tex_name;
metric = tfm;
glyphs = glyphs;
ratio = ratio;
ratio_cm = ratio_cm
}
let load_font =
let memoize = Hashtbl.create 15 in
fun (fdef : font_def) (doc_conv : float) ->
try
Hashtbl.find memoize (doc_conv,fdef.name)
with
Not_found ->
let result = load_font doc_conv fdef in
Hashtbl.add memoize (doc_conv,fdef.name) result;
result
let char_width t c = Metric.char_width t.metric c *. t.ratio
let char_height t c = Metric.char_height t.metric c *. t.ratio
let char_depth t c = Metric.char_depth t.metric c *. t.ratio
let char_dims t c =
let a,b,c = Metric.char_dims t.metric c and f = t.ratio in
a *. f, b *. f, c *. f
mlpost-0.8.2/dvi/fonts.mli 0000664 0000000 0000000 00000002647 13060465153 0015471 0 ustar 00root root 0000000 0000000 open Dvi_util
(** Load fonts and extract information *)
type type1 = private {
glyphs_tag : int;
(* unique tag *)
glyphs_ft : Cairo_ft.ft_face;
(* the file, pfb or pfa, which define the glyphs *)
glyphs_enc : int -> int;
(* the conversion of the charactersx between tex and the font *)
slant : float option;
extend : float option;
glyphs_ratio_cm : float}
type vf =private {
vf_design_size : float;
vf_font_map : Dvi_util.font_def Dvi_util.Int32Map.t;
(* Font on which the virtual font is defined *)
vf_chars : Dvi.command list Int32H.t;
(* The dvi command which define each character*)}
type glyphs =
| Type1 of type1
| VirtualFont of vf
type t
(** the type of a loaded font *)
val load_font : font_def -> float -> t
(** [load_font def f] loads font [def] scaled by [f] *)
val metric : t -> Tfm.t
(** Obtain the font metric *)
val tex_name : t -> string
(** get the name of the font as used by TeX *)
val ratio_cm : t -> float
(** The font ratio, in cm *)
val glyphs : t -> glyphs
val char_width : t -> int -> float
val char_height : t -> int -> float
val char_depth : t -> int -> float
(** get information about the [i]th char of the font *)
val char_dims : t -> int -> float * float * float
(** width, height, depth of the [i]th char *)
val scale : t -> float -> float
(** [scale t f] scale the given float [f] by [ratio_cm t] *)
val design_size : t -> float
(** the design size of the font *)
mlpost-0.8.2/dvi/fonts_type.mli 0000664 0000000 0000000 00000002603 13060465153 0016522 0 ustar 00root root 0000000 0000000 (**************************************************************************)
(* *)
(* Copyright (C) Johannes Kanig, Stephane Lescuyer *)
(* Jean-Christophe Filliatre, Romain Bardou and Francois Bobot *)
(* *)
(* This software is free software; you can redistribute it and/or *)
(* modify it under the terms of the GNU Library General Public *)
(* License version 2.1, with the special exception on linking *)
(* described in file LICENSE. *)
(* *)
(* This software is distributed in the hope that it will be useful, *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *)
(* *)
(**************************************************************************)
type encoding =
[ `File of string
| `Adobe_remap
| `None]
type font_map =
{ tex_name : string;
human_name : string;
enc_name : string option;
pfab_name : string;
slant : float option;
extend : float option;
}
mlpost-0.8.2/dvi/map_lexer.mll 0000664 0000000 0000000 00000004221 13060465153 0016305 0 ustar 00root root 0000000 0000000 (**************************************************************************)
(* *)
(* Copyright (C) Johannes Kanig, Stephane Lescuyer *)
(* Jean-Christophe Filliatre, Romain Bardou and Francois Bobot *)
(* *)
(* This software is free software; you can redistribute it and/or *)
(* modify it under the terms of the GNU Library General Public *)
(* License version 2.1, with the special exception on linking *)
(* described in file LICENSE. *)
(* *)
(* This software is distributed in the hope that it will be useful, *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *)
(* *)
(**************************************************************************)
(* File lexer.mll *)
{
open Map_parser (* The type token is defined in parser.mli *)
let incr_linenum lexbuf =
let pos = lexbuf.Lexing.lex_curr_p in
lexbuf.Lexing.lex_curr_p <- { pos with
Lexing.pos_lnum = pos.Lexing.pos_lnum + 1;
Lexing.pos_bol = pos.Lexing.pos_cnum;
}
}
let ident = (['-''_''a'-'z''A'-'Z''0'-'9'])+
let float = ['-']?['0'-'9']*'.'['0'-'9']+
let int = ['0'-'9']+
rule pdftex_token = parse
[' ' '\t'] { pdftex_token lexbuf } (* skip blanks *)
| ("%" [^'\n']* "\n") {incr_linenum lexbuf; pdftex_token lexbuf } (* comment *)
| ['\n' ] { incr_linenum lexbuf; EOL }
| '"' { DQUOTE }
| "ExtendFont" { EXTEND }
| "SlantFont" { SLANT }
| "ReEncodeFont" { REENCODEFONT }
| '<' ('<' |'[')? ' '* (ident ".enc" as a) { IDENC a }
| '<' ('<' |'[')? ' '* (ident ".pf" ['a''b'] as a) { IDPFAB a}
| '<' ('<' |'[')? ' '* (ident ".ttf" as a) { IDTTF a}
| ident as a { ID a }
| float as a { FLOAT (float_of_string a) }
| eof { EOF }
mlpost-0.8.2/dvi/map_parser.mly 0000664 0000000 0000000 00000005433 13060465153 0016505 0 ustar 00root root 0000000 0000000 /**************************************************************************/
/* */
/* Copyright (C) Johannes Kanig, Stephane Lescuyer */
/* Jean-Christophe Filliatre, Romain Bardou and Francois Bobot */
/* */
/* This software is free software; you can redistribute it and/or */
/* modify it under the terms of the GNU Library General Public */
/* License version 2.1, with the special exception on linking */
/* described in file LICENSE. */
/* */
/* This software is distributed in the hope that it will be useful, */
/* but WITHOUT ANY WARRANTY; without even the implied warranty of */
/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. */
/* */
/**************************************************************************/
/* File parser.mly */
%{
open Fonts_type
let enc = ref None
let slant = ref None
let extend = ref None
let pfab = ref None
let compose tex human =
match !pfab with
|None -> (Parsing.parse_error "No pfab for this font ttf");None
|Some v_pfab ->
let font = {tex_name = tex;
human_name = human;
enc_name = !enc;
pfab_name = v_pfab;
slant = !slant;
extend = !extend
} in
(slant := None;
extend := None;
enc := None;
pfab := None;Some font)
let add_some l = function
| None -> l
| Some a -> a::l
%}
%token FLOAT
%token ID IDENC IDPFAB IDTTF
%token EOL EOF
%token REMAP SLANT EXTEND
%token DQUOTE LESS
%token DEFAULT NONE
%token REENCODEFONT
%type pdftex_main
%start pdftex_main
%%
/*dvipdfm_main pr:
dvipdfm_line EOL dvipdfm_main { pr $1 }
dvipdfm_line EOF {[$1]}
;
dvipdfm_line:
ID ID ID ID
;*/
pdftex_main :
| pdftex_line EOL pdftex_main {add_some $3 $1}
| pdftex_line EOF {add_some [] $1}
| EOL pdftex_main {$2}
| EOF {[]}
;
pdftex_line:
| ID ID pdftex_options {compose $1 $2}
| ID pdftex_options {compose $1 $1}
pdftex_options:
| {}
| DQUOTE pdftex_options_aux DQUOTE pdftex_options {$2}
| IDENC pdftex_options {enc:=Some $1}
| IDPFAB pdftex_options {pfab:=Some $1}
| IDTTF pdftex_options {pfab:=None}
pdftex_options_aux:
| {}
| FLOAT SLANT pdftex_options_aux {slant:=Some $1}
| FLOAT EXTEND pdftex_options_aux {extend:=Some $1}
| ID REENCODEFONT pdftex_options_aux {}
mlpost-0.8.2/dvi/metric.ml 0000664 0000000 0000000 00000001562 13060465153 0015445 0 ustar 00root root 0000000 0000000 type t = Tfm.t
open Tfm
(* compute index of the character *)
let to_abs_idx t i = i - t.file_hdr.bc
(* get info struct of character *)
let get_info t i = t.body.char_info.(to_abs_idx t i)
let char_width t c = t.body.width.((get_info t c).width_index)
let char_height t c = t.body.height.((get_info t c).height_index)
let char_depth t c = t.body.depth.((get_info t c).depth_index)
let char_italic t c = t.body.italic.((get_info t c).italic_index)
let char_dims t c =
let i = get_info t c in
let b = t.body in
b.width.(i.width_index),
b.height.(i.height_index),
b.depth.(i.depth_index)
let slant t = t.body.param.(0)
let space t = t.body.param.(1)
let space_stretch t = t.body.param.(2)
let space_shrink t = t.body.param.(3)
let x_height t = t.body.param.(4)
let quad t = t.body.param.(5)
let extra_space t = t.body.param.(6)
(* is the size of one em in the font. *)
mlpost-0.8.2/dvi/metric.mli 0000664 0000000 0000000 00000002762 13060465153 0015621 0 ustar 00root root 0000000 0000000 (** A high-level interface for Font metrics *)
type t = Tfm.t
val char_width : t -> int -> float
(** [char_width t i] returns the width of the [i]th character of the font metric
[t], [0] is the first character *)
val char_height : t -> int -> float
(** same as [char_width], but for character height *)
val char_depth : t -> int -> float
(** same as [char_width], but for character depth *)
val char_italic : t -> int -> float
(** same as [char_width], but for italic correction of the character *)
val char_dims : t -> int -> float * float * float
(** [char_dims metric i] returns the width, height and depth of the [i]th
char, slightly more efficient than invoking the other functions three times *)
val slant : t -> float
(** is the amount of italic slant, which is used to help position accents. For
example, slant=.25 means that when you go up one unit, you also go .25 units
to the right. *)
val space : t -> float
(** is the normal spacing between words in text. Note that character " " in the
font need not have anything to do with blank spaces. *)
val space_stretch : t -> float
(** is the amount of glue stretching between words. *)
val space_shrink : t -> float
(** is the amount of glue shrinking between words. *)
val x_height : t -> float
(** is the height of letters for which accents don't have to be raised or
lowered. *)
val quad : t -> float
(** is the size of one em in the font. *)
val extra_space : t -> float
(** is the amount added to [space] at the ends of sentences. *)
mlpost-0.8.2/dvi/myocamlbuild.ml 0000664 0000000 0000000 00000006413 13060465153 0016643 0 ustar 00root root 0000000 0000000 open Ocamlbuild_plugin
(* open Command -- no longer needed for OCaml >= 3.10.2 *)
(* these functions are not really officially exported *)
let run_and_read = Ocamlbuild_pack.My_unix.run_and_read
let blank_sep_strings = Ocamlbuild_pack.Lexers.blank_sep_strings
let split s ch =
let x = ref [] in
let rec go s =
let pos = String.index s ch in
x := (String.before s pos)::!x;
go (String.after s (pos + 1))
in
try
go s
with Not_found -> !x
let split_nl s = split s '\n'
let before_space s =
try
String.before s (String.index s ' ')
with Not_found -> s
(* this lists all supported packages *)
let find_packages () =
List.map before_space (split_nl & run_and_read "ocamlfind list")
let syntaxes = ["bitstring","/usr/lib/ocaml/bitstring",
"camlp4o -I /usr/lib/ocaml/bitstring bitstring.cma bitstring_persistent.cma pa_bitstring.cmo"]
(* ocamlfind command *)
let ocamlfind x = S[A"ocamlfind"; x]
let _ = dispatch begin function
| Before_options ->
(* by using Before_options one let command line options have an higher priority *)
(* on the contrary using After_options will guarantee to have the higher priority *)
(* override default commands by ocamlfind ones *)
Options.ocamlc := ocamlfind & A"ocamlc";
Options.ocamlopt := ocamlfind & A"ocamlopt";
Options.ocamldep := ocamlfind & A"ocamldep";
Options.ocamldoc := ocamlfind & A"ocamldoc";
Options.ocamlmktop := ocamlfind & A"ocamlmktop"
| After_rules ->
(* When one link an OCaml library/binary/package, one should use -linkpkg *)
flag ["ocaml"; "link"] & A"-linkpkg";
(* For each ocamlfind package one inject the -package option when
* compiling, computing dependencies, generating documentation and
* linking. *)
List.iter begin fun pkg ->
flag ["ocaml"; "compile"; "pkg_"^pkg] & S[A"-package"; A pkg];
flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S[A"-package"; A pkg];
flag ["ocaml"; "doc"; "pkg_"^pkg] & S[A"-package"; A pkg];
flag ["ocaml"; "link"; "pkg_"^pkg] & S[A"-package"; A pkg];
flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S[A"-package"; A pkg];
end (find_packages ());
(* Like -package but for extensions syntax. Morover -syntax is useless
* when linking. *)
List.iter begin function syntax,lib,pp ->
flag ["ocaml"; "compile"; "syntax_"^syntax] & S[A"-pp"; A pp];
flag ["ocaml"; "ocamldep"; "syntax_"^syntax] & S[A"-pp"; A pp];
flag ["ocaml"; "doc"; "syntax_"^syntax] & S[A"-pp"; A pp];
end syntaxes;
(* The default "thread" tag is not compatible with ocamlfind.
Indeed, the default rules add the "threads.cma" or "threads.cmxa"
options when using this tag. When using the "-linkpkg" option with
ocamlfind, this module will then be added twice on the command line.
To solve this, one approach is to add the "-thread" option when using
the "threads" package using the previous plugin.
*)
flag ["ocaml"; "pkg_threads"; "compile"] (S[A "-thread"]);
flag ["ocaml"; "pkg_threads"; "link"] (S[A "-thread"]);
flag ["ocaml"; "pkg_threads"; "infer_interface"] (S[A "-thread"])
| _ -> ()
end
mlpost-0.8.2/dvi/pfb_lexer.mll 0000664 0000000 0000000 00000006777 13060465153 0016321 0 ustar 00root root 0000000 0000000 (**************************************************************************)
(* *)
(* Copyright (C) Johannes Kanig, Stephane Lescuyer *)
(* Jean-Christophe Filliatre, Romain Bardou and Francois Bobot *)
(* *)
(* This software is free software; you can redistribute it and/or *)
(* modify it under the terms of the GNU Library General Public *)
(* License version 2.1, with the special exception on linking *)
(* described in file LICENSE. *)
(* *)
(* This software is distributed in the hope that it will be useful, *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *)
(* *)
(**************************************************************************)
(* File lexer.mll *)
{
open Format
open Pfb_parser (* The type token is defined in parser.mli *)
let incr_linenum lexbuf =
let pos = lexbuf.Lexing.lex_curr_p in
lexbuf.Lexing.lex_curr_p <- { pos with
Lexing.pos_lnum = pos.Lexing.pos_lnum + 1;
Lexing.pos_bol = pos.Lexing.pos_cnum;
}
type state = |Header | Encoding | Charstring
let state = ref Header
}
let ident = (['.''-''_''a'-'z''A'-'Z''0'-'9'])+
let float = ['-']?['0'-'9']*'.'['0'-'9']+
let int = ['0'-'9']+
rule header_token = parse
| "/Encoding" [^'\n']* '\n' [^'\n']* '\n' {incr_linenum lexbuf;
incr_linenum lexbuf;
state:=Encoding; DUMB}
| [^'\n']* '\n' {incr_linenum lexbuf;
header_token lexbuf}
| _ {eprintf "During header parsing\n"; failwith ""}
and encoding_token = parse
| "dup " (int as id) {ID_ENCODING (int_of_string id)}
| ' '* '/' (ident as id) " put\n" {incr_linenum lexbuf;
NAME_ENCODING id}
| "readonly" {shortcut_token lexbuf}
| _ {eprintf "During encoding parsing@."; failwith ""}
and shortcut_token = parse
| [^'/']* "/CharStrings" [^'\n']* '\n' {incr_linenum lexbuf;
state:=Charstring; DUMB}
| [^'\n']* '\n' {incr_linenum lexbuf;
shortcut_token lexbuf}
| _ {eprintf "During middle parsing@.";failwith ""}
and charstring_token = parse
| '/' (ident as id) [^'{''\n']* '{' [^'}']* '}' [^'\n']* '\n'
{incr_linenum lexbuf; NAME_CHARSTRING id}
| '/' (ident as id) [^'\n']* '\n'
{incr_linenum lexbuf; NAME_CHARSTRING id}
| "end" [^'\n']* '\n' {end_token lexbuf}
| [^'\n']* '\n' {incr_linenum lexbuf;charstring_token lexbuf}
| _ {Printf.eprintf "During charstring parsing@."; failwith ""}
and end_token = parse
| _* eof {state:=Header; DUMB}
| _ {eprintf "During end parsing@."; failwith ""}
and enc_token = parse
| '%' [^'\n']* '\n' {incr_linenum lexbuf; enc_token lexbuf}
| '/' [^'[']* '[' '\n' {incr_linenum lexbuf; DUMB}
| '/' (ident as a) {NAME_ENCODING a}
| '\n' {incr_linenum lexbuf; enc_token lexbuf}
| [' ''\t']* {enc_token lexbuf}
| ']' _* eof {DUMB}
| _ {failwith "enc token not exhaustive"}
{
let pfb_human_token x =
match !state with
|Header -> header_token x
|Encoding -> encoding_token x
|Charstring -> charstring_token x
}
mlpost-0.8.2/dvi/pfb_parser.mly 0000664 0000000 0000000 00000003472 13060465153 0016500 0 ustar 00root root 0000000 0000000 /**************************************************************************/
/* */
/* Copyright (C) Johannes Kanig, Stephane Lescuyer */
/* Jean-Christophe Filliatre, Romain Bardou and Francois Bobot */
/* */
/* This software is free software; you can redistribute it and/or */
/* modify it under the terms of the GNU Library General Public */
/* License version 2.1, with the special exception on linking */
/* described in file LICENSE. */
/* */
/* This software is distributed in the hope that it will be useful, */
/* but WITHOUT ANY WARRANTY; without even the implied warranty of */
/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. */
/* */
/**************************************************************************/
/* File parser.mly */
%{
open Fonts_type
let encoding_table = ref (Array.create 256 "")
%}
%token NAME_CHARSTRING, NAME_ENCODING
%token ID_ENCODING
%token DUMB
%type <(string array) * (string list)> pfb_human_main
%type enc_main
%start pfb_human_main enc_main
%%
pfb_human_main :
DUMB encoding DUMB charstrings DUMB{
let rencoding_table = !encoding_table in
encoding_table := Array.create 256 "";
(rencoding_table,$4)}
encoding :
| {}
| ID_ENCODING NAME_ENCODING encoding {(!encoding_table).($1)<-$2 }
charstrings :
| {[]}
| NAME_CHARSTRING charstrings { $1::$2}
enc_main :
| DUMB enc_aux DUMB {$2}
enc_aux :
| {[]}
| NAME_ENCODING enc_aux {$1::$2}
mlpost-0.8.2/dvi/tfm.ml 0000664 0000000 0000000 00000021041 13060465153 0014742 0 ustar 00root root 0000000 0000000 (**************************************************************************)
(* *)
(* Copyright (C) Johannes Kanig, Stephane Lescuyer *)
(* Jean-Christophe Filliatre, Romain Bardou and Francois Bobot *)
(* *)
(* This software is free software; you can redistribute it and/or *)
(* modify it under the terms of the GNU Library General Public *)
(* License version 2.1, with the special exception on linking *)
(* described in file LICENSE. *)
(* *)
(* This software is distributed in the hope that it will be useful, *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *)
(* *)
(**************************************************************************)
open Format
type file_hdr = {
lf : int;
lh : int;
bc : int;
ec : int;
nw : int;
nh : int;
nd : int;
ni : int;
nl : int;
nk : int;
ne : int;
np : int;
}
type fix_word = float
type header = {
checksum : int32;
design_size : fix_word;
coding_scheme : string option;
identifier : string option;
seven_bit_safe_flag : int option;
face : int option;
}
type char_info_word = {
width_index : int;
height_index : int;
depth_index : int;
italic_index : int;
tag : int;
info_remainder : int
}
type lig_kern_command = {
skip_byte : int;
next_char : int;
op_byte : int;
kern_remainder : int;
}
type extensible_recipe = {
top : int;
mid : int;
bot : int;
rep : int;
}
type body = {
header : header;
char_info : char_info_word array;
width : fix_word array;
height : fix_word array;
depth : fix_word array;
italic : fix_word array;
lig_kern : lig_kern_command array;
kern : fix_word array;
exten : extensible_recipe array;
param : fix_word array;
}
type t = {
file_hdr : file_hdr;
body : body
}
module Print = struct
let file_hdr fmt fh =
fprintf fmt "File header :\n";
fprintf fmt " lf=%d; lh=%d; bc=%d; ec=%d;\n" fh.lf fh.lh fh.bc fh.ec;
fprintf fmt " nw=%d; nh=%d; nd=%d; ni=%d;\n" fh.nw fh.nh fh.nh fh.ni;
fprintf fmt " nl=%d; nk=%d; ne=%d; np=%d;\n" fh.nl fh.nk fh.ne fh.np
let wd fmt (wd : fix_word) =
pp_print_float fmt wd
let wds fmt a =
Array.iteri (fun i c -> fprintf fmt " %d : %a\n" i wd c) a
let header fmt hdr =
fprintf fmt " Header : Checksum = %lx; Design size = %a\n"
hdr.checksum wd hdr.design_size
let info fmt info =
fprintf fmt " Char : Width = %d, Height = %d, Depth = %d, Italic = %d\n"
info.width_index info.height_index info.depth_index info.italic_index;
fprintf fmt " tag = %d; remainder = %d\n" info.tag info.info_remainder
let infos fmt infos =
Array.iter (fun c -> fprintf fmt "%a" info c) infos
let kern_cmd fmt kc =
fprintf fmt " Lig Kern command : skip = %d, next = %d, op = %d, rem = %d\n"
kc.skip_byte kc.next_char kc.op_byte kc.kern_remainder
let kern_cmds fmt kcs =
Array.iter (fun c -> fprintf fmt "%a" kern_cmd c) kcs
let recipe fmt r =
fprintf fmt " Recipe : top = %d, mid = %d, bot = %d, rep = %d\n"
r.top r.mid r.bot r.rep
let recipes fmt rs =
Array.iter (fun c -> fprintf fmt "%a" recipe c) rs
let body fmt body =
fprintf fmt "Body : \n%a\n" header body.header;
fprintf fmt "%a Widths:\n%a Heights:\n%a Depths:\n%a Italic:\n%a"
infos body.char_info wds body.width wds body.height
wds body.depth wds body.italic;
fprintf fmt "%a Kerns:\n%a%a Params:\n%a"
kern_cmds body.lig_kern wds body.kern recipes body.exten wds body.param
let tfm name fmt {file_hdr = fh; body = bdy} =
fprintf fmt "***********************\n";
fprintf fmt "Reading Tex Font Metrics file : %s\n" name;
fprintf fmt "%a%a" file_hdr fh body bdy
end
exception TfmError of string ;;
let tfm_error s = raise (TfmError s)
let tfm_assert d a = if a then () else tfm_error d
let read_n dummy f n bits =
let a = Array.make n dummy in
let rec iter_until i bits =
if i = n then bits
else
let wd, bits = f bits in
a.(i) <- wd; iter_until (i+1) bits
in
let bits = iter_until 0 bits in
a, bits
let epsilon = 1./.(2.**20.)
let fix_word bits =
bitmatch bits with
| { word : 32 : bigendian; bits : -1 : bitstring} ->
(Int32.to_float word) *. epsilon, bits
| { _ : -1 : bitstring } ->
tfm_error "ill-formed fix_word"
let read_n_fixwds = read_n 0. fix_word
let file_hdr bits =
bitmatch bits with
| { lf : 16 : unsigned, bigendian;
lh : 16 : unsigned, bigendian;
bc : 16 : unsigned, bigendian;
ec : 16 : unsigned, bigendian;
nw : 16 : unsigned, bigendian;
nh : 16 : unsigned, bigendian;
nd : 16 : unsigned, bigendian;
ni : 16 : unsigned, bigendian;
nl : 16 : unsigned, bigendian;
nk : 16 : unsigned, bigendian;
ne : 16 : unsigned, bigendian;
np : 16 : unsigned, bigendian;
bits : -1 : bitstring
} ->
tfm_assert "number of characters" (bc-1 <= ec && ec <= 255);
tfm_assert "extensible character table too big" (ne <= 256);
tfm_assert "total size constraint"
(lf = 6+lh+(ec-bc+1)+nw+nh+nd+ni+nl+nk+ne+np);
{ lf = lf; lh = lh; bc = bc; ec = ec;
nw = nw; nh = nh; nd = nd; ni = ni;
nl = nl; nk = nk; ne = ne; np = np
}, bits
| { _ : -1 : bitstring } ->
tfm_error "ill formed header"
let header sz bits =
bitmatch bits with
| { checksum : 32 : bigendian; bits : -1 : bitstring } ->
begin
let design, bits = fix_word bits in
bitmatch bits with
| { _ : (sz-2)*32 : string; bits : -1 : bitstring } ->
{ checksum = checksum;
design_size = design;
coding_scheme = None;
identifier = None;
seven_bit_safe_flag = None;
face = None;
}, bits
| { _ : -1 : bitstring } ->
tfm_error "ill-formed body header2"
end
| { _ : -1 : bitstring } ->
tfm_error "ill-formed body header1"
let dummy_info = {
width_index = 0;
height_index = 0;
depth_index = 0;
italic_index = 0;
tag = 0;
info_remainder = 0
}
let char_info_word bits =
bitmatch bits with
| { width_idx : 8; height_idx : 4; depth_idx : 4;
italic_idx : 6; tag : 2; remainder : 8;
bits : -1 : bitstring
} ->
{ width_index = width_idx; height_index = height_idx;
depth_index = depth_idx; italic_index = italic_idx;
tag = tag; info_remainder = remainder
}, bits
| { _ : -1 : bitstring } ->
tfm_error "ill-formed char info word"
let read_info_words = read_n dummy_info char_info_word
let kern_dummy = {
skip_byte = 0; next_char = 0; op_byte = 0; kern_remainder = 0
}
let lig_kern_cmd bits =
bitmatch bits with
| { skip_byte : 8; next_char : 8; op_byte : 8; remainder : 8;
bits : -1 : bitstring } ->
{ skip_byte = skip_byte; next_char = next_char ;
op_byte = op_byte; kern_remainder = remainder;
}, bits
| { _ : -1 : bitstring } ->
tfm_error "ill-formed lig kern command"
let read_kern_cmds = read_n kern_dummy lig_kern_cmd
let recipe_dummy = {
top = 0; mid = 0; bot = 0; rep = 0;
}
let exten_recipe bits =
bitmatch bits with
| { top : 8; mid : 8; bot : 8; rep : 8;
bits : -1 : bitstring } ->
{ top = top; mid = mid; bot = bot; rep = rep}, bits
| { _ : -1 : bitstring } ->
tfm_error "ill-formed extensible recipe"
let read_recipes = read_n recipe_dummy exten_recipe
let body fh bits =
let hdr, bits = header fh.lh bits in
let infos, bits = read_info_words (fh.ec - fh.bc + 1) bits in
let width, bits = read_n_fixwds fh.nw bits in
let height, bits = read_n_fixwds fh.nh bits in
let depth, bits = read_n_fixwds fh.nd bits in
let italic, bits = read_n_fixwds fh.ni bits in
let lig_kern, bits = read_kern_cmds fh.nl bits in
let kern, bits = read_n_fixwds fh.nk bits in
let exten, bits = read_recipes fh.ne bits in
let param, bits = read_n_fixwds fh.np bits in
if Bitstring.bitstring_length bits <> 0 then
printf "Warning : ignored extra data after parameters.\n";
{ header = hdr;
char_info = infos;
width = width; height = height; depth = depth; italic = italic;
lig_kern = lig_kern; kern = kern;
exten = exten; param = param;
}
let read_file file =
let bits = Bitstring.bitstring_of_file file in
let fh, bits = file_hdr bits in
if Defaults.get_debug () then
Print.file_hdr std_formatter fh;
let body = body fh bits in
{ file_hdr = fh; body = body }
let design_size t = t.body.header.design_size
mlpost-0.8.2/dvi/tfm.mli 0000664 0000000 0000000 00000004204 13060465153 0015115 0 ustar 00root root 0000000 0000000 (** A low level interface for TeX Font Metric (Tfm) files *)
(** The structure of the types follows very closely the one of Tfm files. See
documentation for this file type to get more detailed information about the
record fields. *)
type file_hdr = {
lf : int; (** length of the entire file, in words *)
lh : int; (** length of the header data, in words *)
bc : int; (** smallest character code in the font *)
ec : int; (** largest character code in the font *)
nw : int; (** number of words in the width table *)
nh : int; (** number of words in the height table *)
nd : int; (** number of words in the depth table *)
ni : int; (** number of words in the italic correction table *)
nl : int; (** number of words in the lig/kern table *)
nk : int; (** number of words in the kern table *)
ne : int; (** number of words in the extensible character table *)
np : int; (** number of font parameter words *)
}
type fix_word = float
type header = {
checksum : int32; (** font checksum *)
design_size : fix_word; (** The font design size *)
coding_scheme : string option;
identifier : string option;
seven_bit_safe_flag : int option;
face : int option;
}
type char_info_word = {
width_index : int;
height_index : int;
depth_index : int;
italic_index : int;
tag : int;
info_remainder : int
}
(** information about a char *)
type lig_kern_command = {
skip_byte : int;
next_char : int;
op_byte : int;
kern_remainder : int;
}
(** a kerning command *)
type extensible_recipe = {
top : int;
mid : int;
bot : int;
rep : int;
}
(** information about extensible characters *)
type body = {
header : header;
char_info : char_info_word array;
width : fix_word array;
height : fix_word array;
depth : fix_word array;
italic : fix_word array;
lig_kern : lig_kern_command array;
kern : fix_word array;
exten : extensible_recipe array;
param : fix_word array;
}
(** the body of a Tfm file *)
type t = {
file_hdr : file_hdr;
body : body
}
(** A tfm file *)
val read_file : string -> t
(** read a tfm file *)
val design_size : t -> float
(** accessor for the [design_size] of the font *)
mlpost-0.8.2/examples/ 0000775 0000000 0000000 00000000000 13060465153 0014660 5 ustar 00root root 0000000 0000000 mlpost-0.8.2/examples/.gitignore 0000664 0000000 0000000 00000000142 13060465153 0016645 0 ustar 00root root 0000000 0000000 *.1
*.log
*.tex
*.aux
*.png
*.dvi
*.dummy
*.html
*.ps
*.pdf
*.svg
*.annot
*.cmx
*.cmi
*.o
parse.ml mlpost-0.8.2/examples/Makefile 0000664 0000000 0000000 00000007720 13060465153 0016326 0 ustar 00root root 0000000 0000000 MAX := 17
# all files that are generated from boxes.ml
BOXESPNG := $(foreach i,$(shell seq 1 9), boxes$(i).png)
# all files that are generated from paths.ml
PATHSPNG := $(foreach i,$(shell seq 1 17), paths$(i).png)
# all files that are generated from misc.ml
MISCPNG := $(foreach i,1 2 $(shell seq 4 9) $(shell seq 11 14), misc$(i).png)
# all files that are generated from tree.ml
TREEPNG := $(foreach i,$(shell seq 1 14), tree$(i).png)
# all files that are generated from label.ml
LABELPNG := $(foreach i,$(shell seq 1 2), label$(i).png)
# all files that are generated from automata.ml
AUTOMPNG := automata1.png automata2.png automata4.png
HISTPNG := hist1.png
RADARPNG := radar1.png radar2.png
REALPLOTPNG := real_plot1.png real_plot2.png
COLORPNG := color1.png color2.png color3.png color4.png
INCLUDEPNG := include1.png include2.png include3.png
DOTPNG := dot_dot1.png dot_dot2.png
HTMLFILES := boxes.ml.html paths.ml.html misc.ml.html tree.ml.html \
label.ml.html automata.ml.html hist.ml.html radar.ml.html\
real_plot.ml.html dot_dot.ml.html color.ml.html include.ml.html
MLPOST:=mlpost -v -ps
ALL := $(BOXESPNG) $(PATHSPNG) $(MISCPNG) $(TREEPNG) $(LABELPNG) $(AUTOMPNG)\
$(HISTPNG) $(RADARPNG) $(REALPLOTPNG) $(COLORPNG) $(INCLUDEPNG)
#Direct mps output
ALL_MPS := $(addprefix mps_,$(ALL))
ALL_CAIRO := $(addprefix cairo_,$(ALL))
ALL_CAIRO_PNG := $(addprefix png_,$(ALL_CAIRO))
ALL_CAIRO_PDF := $(addprefix pdf_,$(ALL_CAIRO))
ALL_CAIRO_PS := $(addprefix ps_,$(ALL_CAIRO))
ALL_CAIRO_SVG := $(addprefix svg_,$(ALL_CAIRO:.png=.svg))
all : all_metapost all_cairo all_mps
all_metapost: $(ALL)
all_mps: $(ALL_MPS)
all_cairo: all_cairo_png all_cairo_ps all_cairo_pdf all_cairo_svg
all_cairo_png: $(ALL_CAIRO_PNG)
all_cairo_pdf: $(ALL_CAIRO_PDF)
all_cairo_ps: $(ALL_CAIRO_PS)
all_cairo_svg: $(ALL_CAIRO_SVG)
.PHONY: all all_metapost all_mps all_cairo all_cairo_png all_cairo_pdf \
all_cairo_ps all_cairo_svg
contrib:$(DOTPNG)\
$(addprefix png_cairo_,$(DOTPNG))\
$(addprefix pdf_cairo_,$(DOTPNG))\
$(addprefix ps_cairo_,$(DOTPNG))\
$(addprefix svg_cairo_,$(DOTPNG:png=svg))
#Compilation
%_dot.native : %_dot.ml
$(MLPOST) -native -contrib dot -dont-execute -compile-name $@ $^
%.native : %.ml
$(MLPOST) -native -dont-execute -compile-name $@ $^
#With Metapost :
$(foreach i,$(shell seq 1 $(MAX)), %$(i).1) : %.native
./$^ -ps
#With direct mps output :
$(foreach i,$(shell seq 1 $(MAX)), mps_%$(i).mps) : %.native
./$^ -mps -prefix "mps_"
#With cairo pdf
$(foreach i,$(shell seq 1 $(MAX)), pdf_cairo_%$(i).pdf) : %.native
./$^ -pdf -cairo -prefix "pdf_cairo_"
#With cairo ps
$(foreach i,$(shell seq 1 $(MAX)), ps_cairo_%$(i).ps) : %.native
./$^ -ps -cairo -prefix "ps_cairo_"
#With cairo png
$(foreach i,$(shell seq 1 $(MAX)), png_cairo_%$(i).png) : %.native
./$^ -png -cairo -prefix "png_cairo_"
#With cairo svg
$(foreach i,$(shell seq 1 $(MAX)), svg_cairo_%$(i).svg) : %.native
./$^ -svg -cairo -prefix "svg_cairo_"
parse.ml: parse.mll
ocamllex parse.mll
parse: parse.ml
ocamlopt.opt -o parse parse.ml
#Other
html: $(HTMLFILES)
%.ml.html : %.ml parse style.css
caml2html -css -hc -ext "parse:./parse" $*.ml
%.png: %.ps
convert $^ $@
%.png: %.pdf
convert $^ $@
%.pdf.tex: all.pdf.template
sed -e 's/all/$*/' all.pdf.template > $@
%.tex: all.template
sed -e 's/all/$*/' all.template > $@
%.ps: %.1 %.tex
latex $*
dvips -E $*.dvi -o
%.pdf: %.mps %.pdf.tex
pdflatex $*.pdf.tex
mv $*.pdf.pdf $*.pdf
# %.pdf: %.mps all.template2
# sed -e 's/all/$*/' all.template2 > $*.tex
# pdflatex $*
# %.mps: %.1
# cp $*.1 $*.mps
ALLTEX:=$(ALL:.png=.tex) $(ALL_MPS:.png=.pdf.tex)
clean:
rm -f *.aux *.dvi *.ps *.1 *.log $(PNGFILES) *.mp *.mpx *.mps *.pdf
rm -f $(ALLTEX)
rm -f $(HTML)
rm -f parse.ml *.cmx *.cmo *.cmi parse *.o
rm -f *.dummy *.dummy_dot *.native *.annot
rm -f $(filter-out powered-by-caml.128x58.png,$(wildcard *.png))
editor2 :
ocamlbuild editor2.native
lattice_lablgtk : lattice_lablgtk.ml
$(MLPOST) -contrib lablgtk lattice_lablgtk.ml
mlpost-0.8.2/examples/README 0000664 0000000 0000000 00000001362 13060465153 0015542 0 ustar 00root root 0000000 0000000 To compile the examples, issue
make
Note that this only compiles the images. If you want to have the html files as
well, do
make html
======Developers notes=============
* You need the latest version of caml2html:
svn checkout svn://svn.forge.ocamlcore.org/svnroot/caml2html
To compile that, you also need camlmix, either by godi, or
http://martin.jambon.free.fr/camlmix/
* using (*html, you can put html into the target file
* code hiding is done via (*parse. currently supported:
<> inserts the javascript code to toggle visibility of an element
<> - close the last opened div
* you can modify parse.mll if you need more than that
mlpost-0.8.2/examples/_tags 0000664 0000000 0000000 00000000341 13060465153 0015676 0 ustar 00root root 0000000 0000000 : pkg_lablgtk2, pkg_cairo.lablgtk2
: pkg_lablgtk2, pkg_cairo.lablgtk2, pkg_mlpost
: pkg_lablgtk2, pkg_cairo.lablgtk2, pkg_mlpost
: pkg_mlpost, pkg_mlpost_lablgtk mlpost-0.8.2/examples/all.template 0000664 0000000 0000000 00000000372 13060465153 0017167 0 ustar 00root root 0000000 0000000 \documentclass{article}
\usepackage{graphicx}
\pagestyle{empty}
\usepackage[paperwidth=1000pt, paperheight=2000pt]{geometry}
\begin{document}
\includegraphics{all.mps}
\end{document}
%%% Local Variables:
%%% mode: latex
%%% TeX-master: t
%%% End:
mlpost-0.8.2/examples/all.template2 0000664 0000000 0000000 00000000306 13060465153 0017246 0 ustar 00root root 0000000 0000000 \documentclass{article}
\usepackage{graphicx}
\pagestyle{empty}
\begin{document}
\includegraphics[scale=3]{all.mps}
\end{document}
%%% Local Variables:
%%% mode: latex
%%% TeX-master: t
%%% End:
mlpost-0.8.2/examples/animations.ml 0000664 0000000 0000000 00000010717 13060465153 0017362 0 ustar 00root root 0000000 0000000 open Mlpost
module P = Path
module N = Num
open Point
let (|>) x f = f x
let red dir distmax distmin =
let l = dir
|> length
|> N.minn (N.bp distmax)
|> N.maxn (N.bp distmin) in
scale l (normalize dir)
let little_man ~phead ~plhand ~prhand ~plfoot ~prfoot =
let downbody = origin in
let upbody = bpp (0.,1.) in
let armfac = 0.75 in
let body = P.pathp [downbody;upbody] in
let dneck = (sub phead upbody) in
let neck,head =
let red = red dneck 0.75 0.25 in
(add (scale (N.bp (0.5/.0.75)) red) upbody
,add red upbody) in
let head = P.fullcircle
|> P.scale (N.bp 0.5)
|> P.shift head in
let neck = P.pathp [neck;upbody] in
let handbody = scale (N.bp armfac) upbody in
let pos anchor dir =
(add anchor (red (sub dir anchor) 1. 0.10)) in
let hand dir =
let c = P.fullcircle
|> P.scale (N.bp 0.1) in
let p = (pos handbody dir) in
(P.shift p c,p) in
let lhand,plhand = hand plhand in
let rhand,prhand = hand prhand in
let foot dir =
let c = P.fullcircle
|> P.scale (N.bp 0.1) in
let p = (pos origin dir) in
(P.shift p c,p) in
let lfoot,plfoot = foot plfoot in
let rfoot,prfoot = foot prfoot in
let larm = P.pathp [handbody;plhand] in
let rarm = P.pathp [handbody;prhand] in
let lleg = P.pathp [origin;plfoot] in
let rleg = P.pathp [origin;prfoot] in
[ body;head;neck;larm;rarm;lhand;rhand;lfoot;rleg;lleg;rfoot]
let rot p i = rotate (360.*.i) p
let rot_lit i =
(little_man
~phead:(rot (bpp (0.,2.)) i)
~plhand:(rot (bpp (-.2.,1.)) i)
~prhand:(rot (bpp (2.,1.)) i)
~plfoot:(rot (bpp (-.2.,-1.)) i)
~prfoot:(rot (bpp (2.,-1.)) i)
|> List.map (P.scale (N.cm 1.))
|> List.map P.draw
|> Command.seq)
(*let () = List.iter (fun (s,f) -> Metapost.emit s f)
["little_man0", rot_lit 0.;
"little_man1", rot_lit 0.1;
"little_man2", rot_lit 0.2;
"little_man3", rot_lit 0.3;
"little_man4", rot_lit 0.4;]
*)
let _ = GMain.Main.init ()
let width = ref 400
let height = ref 400
let new_pixmap width height =
let drawable = GDraw.pixmap ~width ~height () in
drawable#set_foreground `WHITE ;
drawable#rectangle
~x:0 ~y:0 ~width ~height ~filled:true () ;
drawable
let pm = ref (new_pixmap !width !height)
let need_update = ref true
let init_time = Unix.gettimeofday ()
let fps =
let nb = ref 0 in
let time = ref (Unix.time ()) in
(fun () ->
let time2 = Unix.time () in
if time2 -. !time > 1.
then (Format.printf "fps : %i@." !nb; nb:=0; time := time2)
else incr nb)
let paint () =
let cr = Cairo_lablgtk.create !pm#pixmap in
!pm#rectangle ~x:0 ~y:0
~width:!width ~height:!height ~filled:true ();
let w,h = (float_of_int !width,float_of_int !height) in
let i = (Unix.gettimeofday () -. init_time) in
let fig = (rot_lit i) in
let fig = Picture.shift (ptp (w/.2.,h/.2.)) fig in
fps ();
Cairost.emit_cairo cr (w,h) fig
let refresh da =
need_update := true ;
GtkBase.Widget.queue_draw da#as_widget
let grow_pixmap () =
pm := new_pixmap !width !height ;
need_update := true
(* no need to queue a redraw here, an expose
event should follow the configure, right ? *)
let config_cb ev =
let w = GdkEvent.Configure.width ev in
let h = GdkEvent.Configure.height ev in
let has_grown = w > !width || h > !height in
width := w ;
height := h ;
if has_grown
then grow_pixmap () ;
true
let expose da x y width height =
let gwin = da#misc#window in
let d = new GDraw.drawable gwin in
d#put_pixmap ~x ~y ~xsrc:x ~ysrc:y ~width ~height !pm#pixmap
let expose_cb da ev =
let area = GdkEvent.Expose.area ev in
let module GR = Gdk.Rectangle in
if !need_update then paint () ;
expose da (GR.x area) (GR.y area) (GR.width area) (GR.height area) ;
refresh da;
true
let button_ev da ev =
match GdkEvent.get_type ev with
| `BUTTON_RELEASE -> refresh da;true
| _ -> false
let init packing =
let da = GMisc.drawing_area ~width:!width ~height:!height ~packing () in
da#misc#set_can_focus true ;
da#event#add [ `KEY_PRESS ;
`BUTTON_MOTION ;
`BUTTON_PRESS ; `BUTTON_RELEASE ] ;
ignore (da#event#connect#expose (expose_cb da)) ;
ignore (da#event#connect#configure (config_cb));
ignore (da#event#connect#button_release (button_ev da))
let main =
let w = GWindow.window
~title:"Cairo spline demo"
~allow_grow:true
~allow_shrink:true
() in
ignore (w#connect#destroy GMain.quit) ;
init w#add ;
w#show () ;
GMain.main ()
mlpost-0.8.2/examples/automata.ml 0000664 0000000 0000000 00000016110 13060465153 0017024 0 ustar 00root root 0000000 0000000
(* A small library to draw automata. *)
open Mlpost
open Path
open Point
open Num
open Command
open Box
(*parse <> *)
(* Nodes are boxes (type Box.t), created using functions such as "state" and
"final" below. These boxes are given names using the labeled argument
~name, for further reference in transition drawing. Nodes placement is
left to the user, and is typically performed using alignment functions
such as Box.hbox, Box.vbox or Box.tabularl (see examples below).
Given a set of placed nodes, that is a box containing nodes as sub-boxes,
function "transition" draws a transition from one node to another, given
their names. A label and its position are also given. Optional arguments
outd and ind can be used to control the shape of the arrow (when it must
not be a straight arrow). Function "loop" is used to draw a self-transition,
drawn below a node (it could be easily generalized to draw a loop to the
right of the node, etc.). Finally, function "initial" draws an incoming
arrow to the left of a node (again, it could be generalized).
*)
let state = Box.tex ~dx:(bp 4.) ~style:Circle ~stroke:(Some Color.black)
let final = Box.box ~style:Circle
let transition states tex anchor ?outd ?ind x_name y_name =
let x = Box.get x_name states and y = Box.get y_name states in
let outd = match outd with None -> None | Some a -> Some (vec (dir a)) in
let ind = match ind with None -> None | Some a -> Some (vec (dir a)) in
Arrow.draw ~tex ~anchor (cpath ?outd ?ind x y)
let loop states tex name =
let box = Box.get name states in
let a = Point.shift (Box.south box) (Point.pt (cm 0., cm (-0.4))) in
let c = Box.ctr box in
let p = Path.pathk [
knotp ~r: (vec (dir 225.)) c;
knotp a;
knotp ~l: (vec (dir 135.)) c;
] in
let bp = Box.bpath box in
Arrow.draw ~tex ~anchor:`Bot (cut_after bp (cut_before bp p))
let initial states name =
let b = Box.get name states in
let p = Box.west b in
Arrow.draw (Path.pathp [ Point.shift p (Point.pt (cm (-0.3), zero)); p ])
(*** Examples ***************************************************************)
(*parse <> *)
(*parse <> *)
(****
let state name s = rect ~name ~stroke:None (rect (tex ("$" ^ s ^ "$")))
let automata3 =
let states = tabularl ~hpadding:(cm 1.) ~vpadding:(cm 1.)
[[state "11" "S\\rightarrow E\\bullet";
state "0" "S\\rightarrow\\bullet E";
state "5" "E\\rightarrow\\texttt{int}\\bullet";
];
[state "1" "E\\rightarrow\\bullet E\\texttt{+}E";
state "3" "E\\rightarrow\\bullet\\texttt{(}E\\texttt{)}";
state "2" "E\\rightarrow\\bullet\\texttt{int}";
];
[state "4" "E\\rightarrow E\\bullet\\texttt{+}E";
state "7" "E\\rightarrow E\\texttt{+}\\bullet E";
state "6" "E\\rightarrow\\texttt{(}\\bullet E\\texttt{)}";
];
[state "9" "E\\rightarrow E\\texttt{+}E\\bullet";
state "10" "E\\rightarrow\\texttt{(}E\\texttt{)}\\bullet";
state "8" "E\\rightarrow\\texttt{(}E \\bullet\\texttt{)}";
]
]
in
let eps = "$\\epsilon$" in
let tt s = "\\texttt{" ^ s ^ "}" in
[draw states;
transition states "$E$" `Top "0" "11";
transition states eps `Upleft "0" "1";
transition states eps `Upright "0" "2";
transition states eps `Left "0" "3";
loop states eps "1";
transition states "$E$" `Left "1" "4";
transition states eps `Top "1" "3";
transition states eps `Upright ~outd:20. "1" "2";
transition states (tt "+") `Top "4" "7";
transition states eps `Lowleft "7" "1";
transition states eps `Right "7" "2";
transition states eps `Right "7" "3";
transition states "$E$" `Upleft "7" "9";
transition states (tt "int") `Left "2" "5";
transition states (tt "(") ~outd:(-0.) `Top "3" "6";
transition states "$E$" `Left "6" "8";
transition states (tt ")") `Top "8" "10";
transition states eps ~outd:170. `Lowleft "6" "1";
transition states eps `Right "6" "2";
transition states eps ~outd:160. `Top "6" "3";
]
****)
(*parse <> *)
let () = Metapost.emit "automata1" (Picture.scale (Num.bp 3.) automata1)
let () = Metapost.emit "automata2" (Picture.scale (Num.bp 3.) automata2)
let () = Metapost.emit "automata4" (Picture.scale (Num.bp 2.) automata4)
mlpost-0.8.2/examples/boxes.ml 0000664 0000000 0000000 00000013573 13060465153 0016343 0 ustar 00root root 0000000 0000000 open Mlpost
open Num
open Command
open Helpers
open Path
open Point
open Color
open Box
(*parse <> *)
(*parse <> <> <> <> <> <) x f = f x
let draw_point ?(color=Color.red) t =
Point.draw ~pen:(Pen.scale (bp 4.) Pen.default) ~color t
(* aligne verticalement le barycentre [(west,5);(east,2)] *)
let boxes6 =
let two = Num.bp 2. in
let five = Num.bp 5. in
let tex = tex ~dx:two ~dy:two in
let a = tex "recursively enumerable languages" in
let b = tex "context sensitive" in
let c = tex "context free" in
let add_point t =
let w = corner `West t in
let e = corner `East t in
let p = P.mult (one // (two +/ five)) (P.add (P.mult five w)
(P.mult two e)) in
setp "something" p t in
let a = add_point a in
let b = add_point b in
let c = add_point c in
let points = [a;b;c]
|> List.map (getp "something")
|> List.map draw_point
|> Command.seq in
(*(*Example de dbuggage quand on a le nouveau backend*)
List.iter fun p -> let {Concrete.CPoint.x=x;y=y} =
Concrete.cpoint_of_point (getp "something" p) in
Format.printf "x = %f; y = %f@." x y) [a;b;c];*)
Command.seq [
points;
Box.draw (vbox ~pos:(`Custom (getp "something")) [a;b;c])]
(*parse >> < Point.add (Point.scale (bp 0.5) (ctr b))
(Point.scale (bp 0.5) (corner `Southeast b))))
] in
Command.seq boxes
(*parse >> < 90. && arc < 270. then
Box.rotate 180. b else b in
let b = Box.center up b in
let t = Transform.rotate_around P.origin arc in
Box.transform [t] b in
let rec aux acc = function
| x when x=n -> acc
| n ->
let a = (float_of_int n)*.arc in
let a = mod_float a 360. in
aux (turn a (f n)::acc) (n+1) in
aux [] 0
let place_circle_ ?auto_inverse r n f =
let arc = 360./.(float_of_int n) in
place_around ?auto_inverse r arc n f
let boxes8 =
let yop d i = Box.circle (Box.tex (Printf.sprintf "$%i_{%02d}$" d i)) in
let rec aux acc = function
| 0 -> acc
| i ->
let n = (float_of_int (i*10))**0.8 in
let r = cm (2.8*.n/.15.) in
let n = int_of_float n in
aux (Box.draw (Box.group (place_circle_
~auto_inverse:true
r n (yop i)))::acc) (i-1) in
Command.seq (aux [] 3)
(*parse >> <> *)
let () = List.iter (fun (i,fig) ->
Metapost.emit ("boxes"^(string_of_int i))
(Picture.scale (Num.bp 3.) fig))
[1,boxes1;
2,boxes2;
3,boxes3;
4,boxes4;
5,boxes5;
6,boxes6;
7,boxes7;
8,boxes8;
9,boxes9]
mlpost-0.8.2/examples/cairo_test.ml 0000664 0000000 0000000 00000004535 13060465153 0017355 0 ustar 00root root 0000000 0000000 open Mlpost
open Command
open Picture
open Point
open Path
module H = Helpers
(*parse <> *)
(*parse <> <> *)
let bp = Num.bp
let ribbon = MetaPath.concat ~style:(MetaPath.jControls (pt (bp 310.,bp 300.)) (pt (bp 10.,bp 310.))) (MetaPath.start (knotp (pt (bp 110., bp 20.))))
(MetaPath.knotp (pt (bp 210.,bp 20.)))
let ribbon = draw (of_metapath ribbon)
let path_test = path ~style:jCurve (z0::z1::z2::[])
let tg p t = draw (pathp ~style:jLine [point t p;add (point t p) (direction t p)])
let test = seq ((draw path_test)::(List.map (tg path_test) [0.;0.264543;0.5;0.785651;1.;1.3528;1.5;1.8653;2.;]))
let some_cut =
let p = Point.p (10.,10.) in
let p1 = path [0., 0.; 50.,50.] in
let p2 = path [0., 50.; 50.,0.] in
let p3 = cut_after p1 p2 in
seq [ draw p1; draw p3; draw (Path.shift p p2) ]
let w0 = 0.,0.
let w1 = -50.,50.
let w2 = 0.,100.
let w3 = 50.,50.
let labels2 =
seq [H.dotlabels ~pos:`Top ["0";"2"] (map_bp [w0;w2]);
dotlabel ~pos:`Left (tex "3") (bpp w3);
dotlabel ~pos:`Right (tex "1") (bpp w1) ]
(*let circle = seq [ draw (MetaPath.cycle ~style:jCurve (MetaPath.path ~style:jCurve (w0::w1::w2::w3::[])));labels2]*)
let circle = seq [draw (Path.scale (bp 100.) Path.halfcircle);draw (Path.scale (bp 50.) Path.quartercircle)]
let to_export =
[ "other27", other27;
"handbook3", handbook3;
"ribbon", ribbon;
"test", test;
"circle", circle;
"somecut", some_cut;
]
let _ = List.iter (fun (name,fig) -> Metapost.emit name fig) to_export
mlpost-0.8.2/examples/color.ml 0000664 0000000 0000000 00000002003 13060465153 0016323 0 ustar 00root root 0000000 0000000 open Mlpost
module P = Path
module C = Color
(*parse <> *)
(*parse <
let c = C.hsv ((foi fnbh h)*.360.) s (foi fnbv v) in
square c))
let color1 = hsv_grid 10 10 0.
(*parse >> <> <> < square (gc ())))
(*parse >> *)
let () =
List.iter (fun (name,fig) -> Metapost.emit name
(Picture.scale (Num.bp 2.) fig))
["color1",color1;
"color2",color2;
"color3",color3;
"color4",color_gen_line 10]
mlpost-0.8.2/examples/concrete.ml 0000664 0000000 0000000 00000002576 13060465153 0017026 0 ustar 00root root 0000000 0000000 open Mlpost
open Command
module Pi = Picture
module Po = Point
module Pa = Path
module Cn = Concrete
let a = -50., -12.5
let b = -12.5, -50.
let c = 50., -12.5
let d = -12.5, 50.
let e = 50., 12.5
let f = 12.5, 50.
let g = -50., 12.5
let h = 12.5, -50.
let for_joint joint =
let l1 = Pa.path ~style:joint [a; c; e; g] in
let l2 = Pa.path ~style:joint [b; d; f; h] in
(l1,l2)
let fig1 (l1,l2) = seq [draw l1;draw l2]
let fig2 ((l1,l2) as arg) =
let cl1 = Cn.cpath_of_path l1 in
let cl2 = Cn.cpath_of_path l2 in
let inter = Cn.CPath.intersection cl1 cl2 in
let inter1,inter2 = List.split inter in
let inter1 = List.map (Cn.CPath.point_of_abscissa cl1) inter1 in
let inter2 = List.map (Cn.CPath.point_of_abscissa cl2) inter2 in
let inter = inter1@inter2 in
let inter = List.map Cn.point_of_cpoint inter in
let draw_a_point c = draw ~pen:(Pen.scale (Num.bp 4.) Pen.default) ~color:Color.red (Pa.pathp [c]) in
let inter = List.map draw_a_point inter in
let label = label ~pos:`Center (Pi.tex (Format.sprintf "%i intersections" (List.length inter1))) Po.origin in
seq ((fig1 arg)::label::inter)
let _ = List.iter (fun (f,n) -> Metapost.emit n f)
[fig2 (for_joint Pa.jLine),"jLine";
fig2 (for_joint Pa.jCurve),"jCurve"]
let _ = Cairost.emit_svg "concrete.svg" (fig2 (for_joint Pa.jCurve))
let _ = Cairost.emit_ps "concrete.ps" (fig2 (for_joint Pa.jCurve))
mlpost-0.8.2/examples/dot_dot.ml 0000664 0000000 0000000 00000002155 13060465153 0016651 0 ustar 00root root 0000000 0000000 (* mlpost -contrib dot dot.ml *)
open Mlpost
open Mlpost_dot
module Pi = Picture
open Command
(*parse <> *)
(*parse <> <> *)
let () = List.iter (fun (n,f) -> Metapost.emit n f)
["dot_dot1",dot1;
"dot_dot2",dot2]
mlpost-0.8.2/examples/editor2.ml 0000664 0000000 0000000 00000015507 13060465153 0016572 0 ustar 00root root 0000000 0000000 (**************************************************************************)
(* Lablgtk - Examples *)
(* *)
(* There is no specific licensing policy, but you may freely *)
(* take inspiration from the code, and copy parts of it in your *)
(* application. *)
(* *)
(**************************************************************************)
(* $Id: editor2.ml 1347 2007-06-20 07:40:34Z guesdon $ *)
open StdLabels
let _ = GMain.Main.init ()
let file_dialog ~title ~callback ?filename () =
let sel =
GWindow.file_selection ~title ~modal:true ?filename () in
ignore(sel#cancel_button#connect#clicked ~callback:sel#destroy);
ignore(sel#ok_button#connect#clicked ~callback:
begin fun () ->
let name = sel#filename in
sel#destroy ();
callback name
end);
sel#show ()
let input_channel b ic =
let buf = String.create 1024 and len = ref 0 in
while len := input ic buf 0 1024; !len > 0 do
Buffer.add_substring b buf 0 !len
done
let with_file name ~f =
let ic = open_in name in
try f ic; close_in ic with exn -> close_in ic; raise exn
class editor ?packing ?show () = object (self)
val text = GText.view ?packing ?show ()
val mutable filename = None
method text = text
method load_file name =
try
let b = Buffer.create 1024 in
with_file name ~f:(input_channel b);
let s = Glib.Convert.locale_to_utf8 (Buffer.contents b) in
let n_buff = GText.buffer ~text:s () in
text#set_buffer n_buff;
filename <- Some name;
n_buff#place_cursor n_buff#start_iter
with _ -> prerr_endline "Load failed"
method open_file () = file_dialog ~title:"Open" ~callback:self#load_file ()
method save_dialog () =
file_dialog ~title:"Save" ?filename
~callback:(fun file -> self#output ~file) ()
method save_file () =
match filename with
Some file -> self#output ~file
| None -> self#save_dialog ()
method output ~file =
try
if Sys.file_exists file then Sys.rename file (file ^ "~");
let s = text#buffer#get_text () in
let oc = open_out file in
output_string oc (Glib.Convert.locale_from_utf8 s);
close_out oc;
filename <- Some file
with _ -> prerr_endline "Save failed"
method get_text () =
text#buffer#get_text ()
end
let window = GWindow.window ~width:500 ~height:300 ~title:"editor" ()
let vbox = GPack.vbox ~packing:window#add ()
let menubar = GMenu.menu_bar ~packing:vbox#pack ()
let factory = new GMenu.factory ~accel_path:"/" menubar
let accel_group = factory#accel_group
let file_menu = factory#add_submenu "File"
let edit_menu = factory#add_submenu "Edit"
let scrollwin = GBin.scrolled_window ~packing:vbox#add ()
let editor = new editor ~packing:scrollwin#add ()
open Mlpost
let fig () =
let fig = Box.tex (editor#get_text ()) in
let fig = Box.center Point.origin fig in
let fig = Box.scale (Num.bp 2.) fig in
Box.draw fig
let width = 400
let height = 500
let window2 = GWindow.window ~width ~height ~title:"view" ()
let () =
ignore(window2#connect#destroy ~callback:GMain.quit);
ignore(window2#show ())
let new_pixmap width height =
let drawable = GDraw.pixmap ~width ~height () in
drawable#set_foreground `WHITE ;
drawable#rectangle
~x:0 ~y:0 ~width ~height ~filled:true () ;
drawable
let pm = ref (new_pixmap width height)
let need_update = ref true
let paint () =
try
let w,h = (float_of_int width,float_of_int height) in
let fig = Picture.shift (Point.ptp (w/.2.,h/.2.)) (fig ()) in
let _ = Mlpost.Concrete.float_of_num (Picture.width fig) in
let cr = Cairo_lablgtk.create !pm#pixmap in
!pm#rectangle ~x:0 ~y:0
~width ~height ~filled:true ();
Cairost.emit_cairo cr (w,h) fig
with _ -> ()
let refresh da =
need_update := true ;
GtkBase.Widget.queue_draw da#as_widget
let expose da x y width height =
let gwin = da#misc#window in
let d = new GDraw.drawable gwin in
d#put_pixmap ~x ~y ~xsrc:x ~ysrc:y ~width ~height !pm#pixmap
let expose_cb da ev =
let area = GdkEvent.Expose.area ev in
let module GR = Gdk.Rectangle in
if !need_update (*&& editor#text#buffer#modified*) then paint ();
expose da (GR.x area) (GR.y area) (GR.width area) (GR.height area);
need_update := false;
true
let button_ev da ev =
match GdkEvent.get_type ev with
| `BUTTON_RELEASE -> refresh da;true
| _ -> false
let init packing =
let da = GMisc.drawing_area ~width ~height ~packing () in
da#misc#set_can_focus true ;
ignore (da#event#connect#expose (expose_cb da));
da#event#add [ `BUTTON_RELEASE ] ;
ignore (da#event#connect#button_release (button_ev da));
ignore (editor#text#buffer#connect#changed ~callback:(fun _ -> refresh da));
da
let dda =
let dda = init window2#add in
window2#show ();
dda
(** Editor window *)
open GdkKeysyms
let _ =
ignore(window#connect#destroy ~callback:GMain.quit);
let factory = new GMenu.factory ~accel_path:"/////" file_menu ~accel_group
in
ignore(factory#add_item "Open" ~key:_O ~callback:editor#open_file);
ignore(factory#add_item "Save" ~key:_S ~callback:editor#save_file);
ignore(factory#add_item "Save as..." ~callback:editor#save_dialog);
ignore(factory#add_separator ());
ignore(factory#add_item "Quit" ~key:_Q ~callback:window#destroy);
let factory = new GMenu.factory ~accel_path:"///" edit_menu ~accel_group in
ignore(factory#add_item "Copy" ~key:_C ~callback:
(fun () -> editor#text#buffer#copy_clipboard GMain.clipboard));
ignore(factory#add_item "Cut" ~key:_X ~callback:
(fun () -> GtkSignal.emit_unit
editor#text#as_view GtkText.View.S.cut_clipboard));
ignore(factory#add_item "Paste" ~key:_V ~callback:
(fun () -> GtkSignal.emit_unit
editor#text#as_view GtkText.View.S.paste_clipboard));
ignore(factory#add_separator ());
ignore(factory#add_check_item "Word wrap" ~active:false ~callback:
(fun b -> editor#text#set_wrap_mode (if b then `WORD else `NONE)));
ignore(factory#add_check_item "Read only" ~active:false
~callback:(fun b -> editor#text#set_editable (not b)));
ignore(factory#add_item "Save accels"
~callback:(fun () -> GtkData.AccelMap.save "test.accel"));
ignore(factory#add_item "Refresh"
~callback:(fun () -> refresh dda));
ignore(window#add_accel_group accel_group);
ignore(editor#text#event#connect#button_press
~callback:(fun ev ->
let button = GdkEvent.Button.button ev in
if button = 3 then begin
file_menu#popup ~button ~time:(GdkEvent.Button.time ev); true
end else false));
ignore(window#show ());
let () = GtkData.AccelMap.load "test.accel" in
GMain.main ()
mlpost-0.8.2/examples/hist.ml 0000664 0000000 0000000 00000003430 13060465153 0016161 0 ustar 00root root 0000000 0000000 open Mlpost
open Num
open Color
open Box
(*parse <> *)
(*parse <> <> <> <> <> <> <> <> <> <> *)
let _ =
List.iter (fun (name,fig) -> Metapost.emit name fig)
[ "hist1", hist1;
"hist2", hist2;
"hist3", hist3;
"hist4", hist4;
"hist5", hist5;
"hist6", hist6;
"hist7", hist7;
"hist8", hist8;
"hist9", hist9;
"hist10", hist10;
]
mlpost-0.8.2/examples/include.ml 0000664 0000000 0000000 00000001754 13060465153 0016644 0 ustar 00root root 0000000 0000000 open Mlpost
open Command
(*parse <> *)
(*parse <> *)
(*parse <> <> *)
let () = List.iter (fun (i,fig) ->
Metapost.emit ("include"^(string_of_int i)) fig)
[1,include1;
2,include2;
3,include3]
mlpost-0.8.2/examples/index.html 0000664 0000000 0000000 00000001522 13060465153 0016655 0 ustar 00root root 0000000 0000000
Mlpost Examples Section
Mlpost Examples Section
Boxes
Paths
Trees
Labels
Automata
Terms
Color
Radars
Function plot
Other and more complex examples
Include png pictures
Contributions
Mlpost_dot contrib
mlpost-0.8.2/examples/label.ml 0000664 0000000 0000000 00000001774 13060465153 0016302 0 ustar 00root root 0000000 0000000 open Mlpost
open Command
open Picture
open Point
open Path
module H = Helpers
(*parse <> *)
(*parse <> <> *)
let _ =
List.iter (fun (name,fig) -> Metapost.emit name
(Picture.scale (Num.bp 3.) fig))
[ "label1", label1;
"label2", label2;
]
mlpost-0.8.2/examples/lattice_lablgtk.ml 0000664 0000000 0000000 00000005335 13060465153 0020345 0 ustar 00root root 0000000 0000000 open Mlpost
open Command
open Picture
open Path
open Num
open Num.Infix
open Helpers
(** Copy from misc.ml!!! *)
(* type of Box lattice *)
type node = N of Box.t * node list (* a node and its successors *)
type lattice = node list list (* nodes lines, from top to bottom *)
(* drawing *)
let dx = bp 12.
let dy = bp 12.
module H = Hashtbl.Make(struct
type t = Box.t let hash b = Hashtbl.hash b let equal = (==)
end)
let nodes = H.create 97
let draw la =
let line l = Box.hbox ~padding:dx (List.map (function (N (b,_)) -> b) l) in
let to_list b = Array.to_list (Box.elts b) in
let to_list2 b = List.map to_list (to_list b) in
let la' = Box.vbox ~padding:dy (List.map line la) in
List.iter2
(List.iter2 (fun (N (b, _)) b' -> H.add nodes b b'))
la (to_list2 la');
let box b = H.find nodes b in
let draw_node (N (b,l)) =
let b = box b in
Box.draw b ++ iterl (fun (N(s,_)) -> box_arrow b (box s)) l
in
iterl (iterl draw_node) la
(* example: the subwords lattice *)
let node s l =
let s = if s = "" then "$\\varepsilon$" else s in
let s = "\\rule[-0.1em]{0in}{0.8em}" ^ s in
N (Box.circle (Box.tex s), l)
(* folds over the bits of an integer (as powers of two) *)
let fold_bit f =
let rec fold acc n =
if n = 0 then acc else let b = n land (-n) in fold (f acc b) (n - b)
in
fold
(* the bits in [n] indicate the selected characters of [s] *)
let subword s n =
let len = fold_bit (fun l _ -> l+1) 0 n in
let w = String.create len in
let j = ref 0 in
for i = 0 to String.length s - 1 do
if n land (1 lsl i) != 0 then begin w.[!j] <- s.[i]; incr j end
done;
w
(* builds the lattice of [s]'s subwords *)
let subwords s =
let n = String.length s in
let levels = Array.create (n+1) [] in
let memo = Hashtbl.create 97 in
let rec make_node lvl x =
try
Hashtbl.find memo x
with Not_found ->
let n =
node (subword s x)
(fold_bit (fun l b -> make_node (lvl - 1) (x - b) :: l) [] x)
in
Hashtbl.add memo x n;
levels.(lvl) <- n :: levels.(lvl);
n
in
let _ = make_node n (lnot ((-1) lsl n)) in
Array.to_list levels
let lattice s =
draw (subwords s)
(** End of the copy *)
open Mlpost_lablgtk
module L = Mlpost_lablgtk.Interface
let _ = GMain.Main.init ()
let word = ref "abcd"
let int = L.new_interface ()
let () = L.create_text int ~label:"lattice of subwords of"
!word ((:=) word)
let aa ~width ~height _ =
let p = Point.pt (Num.divf width 2.,Num.divf height 2.) in
[Transform.shifted p]
let aa2 ~width ~height pic =
let p = Point.pt (Num.divf width 2.,Num.divf height 2.) in
[Transform.shifted (Point.sub p (Picture.ctr pic))]
let () = L.add_pic ~auto_aspect:aa_fit_page int
(fun () -> lattice !word)
let () = L.main int
mlpost-0.8.2/examples/misc.ml 0000664 0000000 0000000 00000051575 13060465153 0016162 0 ustar 00root root 0000000 0000000 open Mlpost
open Command
open Picture
open Path
open Num
open Num.Infix
open Helpers
(*parse <> *)
(*parse < iter 0 (h-1) (f i));
iter 0 w (fun i -> draw ~pen (pathn [p i 0; p i h]));
iter 0 h (fun j -> draw ~pen (pathn [p 0 j; p w j]))]
let misc1 =
let d = 10. in
let p i j = bp (float i *. d), bp (float j *. d) in
let p2 i j = bp ((0.5 +. float i) *. d), bp ((0.5 +. float j) *. d) in
let pic q i j = draw_pic (Picture.center (Point.pt (p2 i j)) q) in
let cell i j =
if j = bresenham_data.(i) then
let sq = Path.scale (bp d) unitsquare in
let sq = shift (Point.pt (p i j)) sq in
fill ~color:Color.red sq
else
seq []
in
seq [grid (x2+1) (y2+1) d cell;
pic (tex "0") 0 (-1);
pic (tex "0") (-1) 0;
pic (tex "$x_2$") x2 (-1);
pic (tex "$y_2$") (-1) y2;
]
(*parse >> *)
open Diag
(*parse < iter 0 (h-1) (f i));
iter 0 w (fun i -> Command.draw ~pen (pathn [p i 0; p i h]));
iter 0 h (fun j -> Command.draw ~pen (pathn [p 0 j; p w j]))]
let bq = tex "\\font\\Chess=chess10 {\\Chess q}"
let question = tex "?"
let misc3 =
let d = 15. in
let p i j = bp (float i *. d), bp (float j *. d) in
let p2 i j = bp ((0.5 +. float i) *. d), bp ((0.5 +. float j) *. d) in
let pic q i j = draw_pic (Picture.center (Point.pt (p2 i j)) q) in
let cell i j =
let l =
if (i+j) mod 2 = 1 then
let sq = Path.scale (bp d) unitsquare in
let sq = shift (Point.pt (p i j)) sq in
[fill ~color:(Color.gray 0.7) sq]
else
[]
in
seq
(if i = 4 && j = 7 || i = 3 && j = 5 || i = 6 && j = 6 then
l @ [pic bq i j]
else if j = 4 then
l @ [pic question i j]
else
l)
in
grid 8 8 d cell
*)
(*parse >> < Array.init 4
(fun j -> node (foi i) (foi j) (Box.empty ~width:(bp 4.) ())))
(* (Printf.sprintf "(%d,%d)" i j))) *)
let nodesl = List.flatten (List.map Array.to_list (Array.to_list nodes))
let diag = create nodesl
let add = arrow diag ~head:false
let edges =
for i = 0 to 5 do
for j = 0 to 3 do
(try (add ~outd:(Angle 45.) nodes.(i).(j) nodes.(i+1).(j+1)) with _ -> ());
(try (add ~outd:(Angle 135.) nodes.(i).(j) nodes.(i-1).(j+1)) with _ -> ());
(try (add ~outd:Up nodes.(i).(j) nodes.(i).(j+1)) with _ -> ());
done
done
let graph = draw ~fill:(Color.gray 0.8)
~style:(Box.circle ~dx:(Num.bp 6.) ~dy:(Num.bp 6.)) diag
let misc4 = draw_pic (Picture.scale (bp 0.5) (Picture.make graph))
(*parse >> < Array.init 4
(fun j -> (node (foi i) (foi j) (Box.empty ~width:(bp 4.) ()), i, j)))
(* (Printf.sprintf "(%d,%d)" i j), i, j))) *)
let nodesl =
List.fold_left (fun acc (n,i,j) -> if (i+j) mod 2 = 0 then n::acc else acc)
[] (List.flatten (List.map Array.to_list (Array.to_list nodes)))
let diag = create nodesl
let node i j = let (n, _, _) = nodes.(i).(j) in n
let add = arrow diag ~head:false
let edges =
for i = 0 to 5 do
for j = 0 to 3 do
if (i + j) mod 2 = 0 then
begin
(try (add ~outd:(Angle 165.) (node i j) (node (i-3) (j+1))) with _ -> ());
(try (add ~outd:(Angle 135.) (node i j) (node (i-1) (j+1))) with _ -> ());
(try (add ~outd:(Angle 45.) (node i j) (node (i+1) (j+1))) with _ -> ());
(try (add ~outd:(Angle 15.) (node i j) (node (i+3) (j+1))) with _ -> ());
end
done
done
let graph = draw ~fill:(Color.gray 0.8)
~style:(Box.circle ~dx:(Num.bp 6.) ~dy:(Num.bp 6.)) diag
let misc5 = draw_pic (Picture.scale (bp 0.5) (Picture.make graph))
(*parse >> <> < failwith "No empty list allowed"
| [x] -> x
| (x::xs) -> append ~style x (fold_append xs)
let s = 0.004
let xs1 = 48.
let xs2 = 25.
let ys = 19.
let add (a1,a2) (b1,b2) = (a1 +. b1 , a2 +. b2)
let mult f (a1,a2) = (f *. a1, f *. a2)
let myscale = List.map (mult s)
let misc7 =
let pen1 = Pen.circle in
let mygreen = Color.rgb 0.8 0.9 0.8 in
let p1 = ( 750.,8000. -. 4950. ) in
let p2 = (1050.,8000. -. 4950. ) in
let p3 = (2100.,8000. -. 4800. ) in
let p4 = (2925.,8000. -. 4650. ) in
let p5 = (4050.,8000. -. 5100. ) in
let p6 = (4050.,8000. -. 5550. ) in
let p7 = (3750.,8000. -. 6075. ) in
let p8 = (3150.,8000. -. 6900. ) in
let p9 = (3075.,8000. -. 7500. ) in
let p10 = (3525.,8000. -. 7950. ) in
let p11 = (4275.,8000. -. 8775. ) in
let p12 = (5400.,8000. -. 9300. ) in
let p13 = (4725.,8000. -. 8550. ) in
let p14 = (4275.,8000. -. 7725. ) in
let p15 = (4875.,8000. -. 8325. ) in
let p16 = (5550.,8000. -. 8700. ) in
let p17 = (5100.,8000. -. 7950. ) in
let p18 = (4800.,8000. -. 7125. ) in
let p19 = (5400.,8000. -. 7725. ) in
let p20 = (6150.,8000. -. 8100. ) in
let p21 = (5550.,8000. -. 7275. ) in
let p22 = (5250.,8000. -. 6375. ) in
let p23 = (5850.,8000. -. 7050. ) in
let p24 = (6600.,8000. -. 7500. ) in
let p25 = (6075.,8000. -. 6675. ) in
let p26 = (5700.,8000. -. 5775. ) in
let p27 = (6975.,8000. -. 7125. ) in
let p28 = (8625.,8000. -. 7950. ) in
let p29 = (7875.,8000. -. 7350. ) in
let p30 = (7275.,8000. -. 6750. ) in
let p31 = (8175.,8000. -. 7200. ) in
let p32 = (9150.,8000. -. 7425. ) in
let p33 = (8325.,8000. -. 6975. ) in
let p34 = (7725.,8000. -. 6375. ) in
let p35 = (8550.,8000. -. 6750. ) in
let p36 = (9525.,8000. -. 6825. ) in
let p37 = (8625.,8000. -. 6450. ) in
let p38 = (8100.,8000. -. 6000. ) in
let p39 = (9000.,8000. -. 6300. ) in
let p40 = (9975.,8000. -. 6300. ) in
let p41 = (9075.,8000. -. 6000. ) in
let p42 = (8400.,8000. -. 5550. ) in
let p43 = (9525.,8000. -. 5925. ) in
let p44 = (10425.,8000.-. 5925. ) in
let p45 = (9300.,8000. -. 5550. ) in
let p46 = (8250.,8000. -. 5100. ) in
let p47 = (7275.,8000. -. 4875. ) in
let p48 = (6300.,8000. -. 4800. ) in
let p49 = (7275.,8000. -. 4500. ) in
let p50 = (8400.,8000. -. 4500. ) in
let p51 = (7500.,8000. -. 4050. ) in
let p52 = (6825.,8000. -. 3900. ) in
let p53 = (7800.,8000. -. 3825. ) in
let p54 = (8700.,8000. -. 3975. ) in
let p55 = (7875.,8000. -. 3375. ) in
let p56 = (7050.,8000. -. 3075. ) in
let p57 = (8175.,8000. -. 3150. ) in
let p58 = (8925.,8000. -. 3450. ) in
let p59 = (8175.,8000. -. 2775. ) in
let p60 = (7350.,8000. -. 2400. ) in
let p61 = (8250.,8000. -. 2475. ) in
let p62 = (9225.,8000. -. 3000. ) in
let p63 = (8850.,8000. -. 2100. ) in
let p64 = (8400.,8000. -. 1650. ) in
let p66 = (8100.,8000. -. 1875. ) in
let p67 = (7200.,8000. -. 1575. ) in
let p68 = (5850.,8000. -. 1500. ) in
let p69 = (5625.,8000. -. 2025. ) in
let p70 = (5475.,8000. -. 2400. ) in
let p71 = (5100.,8000. -. 3000. ) in
let p72 = (4650.,8000. -. 3750. ) in
let p73 = (3525.,8000. -. 3450. ) in
let p74 = (2550.,8000. -. 3075. ) in
let p75 = (2325.,8000. -. 3375. ) in
let p76 = (2100.,8000. -. 3600. ) in
let p77 = (1425.,8000. -. 4050. ) in
let p78 = ( 975.,8000. -. 4350. ) in
let p79 = ( 525.,8000. -. 4875. ) in
let p80 = (1840.,8000. -. 4600. ) in
let p81 = (2375.,8000. -. 4550. ) in
let line1 = path (myscale [p79;p1;p2;p3;p4;p5]) in
let line2 =
fold_append ~style:jLine
(List.map (fun l -> path (myscale l) )
[ [p9;p10;p11;p12] ; [p12; p13; p14] ;
[p14; p15; p16] ; [p16; p17; p18] ;
[p18; p19; p20] ; [p20; p21; p22] ;
[p22; p23; p24] ; [p24; p25; p26] ;
[p26; p27; p28] ; [p28; p29; p30] ;
[p30; p31; p32] ; [p32; p33; p34] ;
[p34; p35; p36] ; [p36; p37; p38] ;
[p38; p39; p40] ; [p40; p41; p42] ;
[p42; p43; p44] ; [p44; p45; p46] ;
[p46; p47; p48] ; [p48; p49; p50] ;
[p50; p51; p52] ; [p52; p53; p54] ;
[p54; p55; p56] ; [p56; p57; p58] ;
[p58; p59; p60] ; [p60; p61; p62] ;
[p62; p66; p67; p68 ] ]) in
let line3 = path (myscale [p62; p63; p64 ]) in
let line4 = path (myscale [p72; p73; p74 ]) in
let line5 = path (myscale [p79; p80; p81]) in
let line6 = path (myscale [p6; p6; p7; p8; p9 ]) in
let line7 = path (myscale [p74; p75; p76; p77; p78; p78; p79]) in
let line8 = path (myscale [p68; p69; p70; p71; p72]) in
let bird = cycle ~style:jLine
(fold_append ~style:jLine
[line1 ; line6; line2; line8; line4; line7])
in
Command.iter (-1) 1
(fun x ->
Command.iter (-1) 1
(fun y ->
let xf, yf = float_of_int x, float_of_int y in
let offset = (xf *. xs1 +. yf *. xs2, yf *. ys) in
let offset2 = ( (xf +. 1.) *. xs1 +. (yf -. 1.) *. xs2,
(yf -. 1.) *. ys ) in
let tr p = Path.shift (bpp offset) p in
let mypath po =
let offset = add offset2 po in
Path.shift (bpp offset) Path.fullcircle
in
seq ([ fill ~color:Color.red (mypath (-12.,27.));
Command.draw ~color:Color.blue (mypath (-12.,27.))] @
[ fill ~color:mygreen (tr bird)] @
List.map (fun p -> Command.draw ~pen:pen1 (tr p))
[line1;line2;line3;line4;line5] @
List.map (fun p -> Command.draw ~pen:pen1 (tr p))
[line6; line7; line8] ) ) )
(*parse >> < b) l) in
let to_list b = Array.to_list (Box.elts b) in
let to_list2 b = List.map to_list (to_list b) in
let la' = Box.vbox ~padding:dy (List.map line la) in
List.iter2
(List.iter2 (fun (N (b, _)) b' -> H.add nodes b b'))
la (to_list2 la');
let box b = H.find nodes b in
let draw_node (N (b,l)) =
let b = box b in
Box.draw b ++ iterl (fun (N(s,_)) -> box_arrow b (box s)) l
in
iterl (iterl draw_node) la
(* example: the subwords lattice *)
let node s l =
let s = if s = "" then "$\\varepsilon$" else s in
let s = "\\rule[-0.1em]{0in}{0.8em}" ^ s in
N (Box.circle (Box.tex s), l)
(* folds over the bits of an integer (as powers of two) *)
let fold_bit f =
let rec fold acc n =
if n = 0 then acc else let b = n land (-n) in fold (f acc b) (n - b)
in
fold
(* the bits in [n] indicate the selected characters of [s] *)
let subword s n =
let len = fold_bit (fun l _ -> l+1) 0 n in
let w = String.create len in
let j = ref 0 in
for i = 0 to String.length s - 1 do
if n land (1 lsl i) != 0 then begin w.[!j] <- s.[i]; incr j end
done;
w
(* builds the lattice of [s]'s subwords *)
let subwords s =
let n = String.length s in
let levels = Array.create (n+1) [] in
let memo = Hashtbl.create 97 in
let rec make_node lvl x =
try
Hashtbl.find memo x
with Not_found ->
let n =
node (subword s x)
(fold_bit (fun l b -> make_node (lvl - 1) (x - b) :: l) [] x)
in
Hashtbl.add memo x n;
levels.(lvl) <- n :: levels.(lvl);
n
in
let _ = make_node n (lnot ((-1) lsl n)) in
Array.to_list levels
let misc8 =
draw (subwords "abcd")
(*parse >> < 0 then
match t with
| One ->
let d = Point.segment r0 a c in
seq [pave One b c d (n-1); pave Four b d a (n-1) ]
| Two ->
let d = Point.segment r0 a b in
seq [ pave Two c d b (n-1) ; pave Three c a d (n-1) ]
| Three ->
let d = Point.segment r1 a b in
let e = Point.segment r0 a c in
seq [ pave One d c e (n-1) ; pave Three b c d (n-1);
pave Four d e a (n-1)]
| Four ->
let d = Point.segment r1 a c in
let e = Point.segment r0 a b in
seq [ pave Two d e b (n-1) ; pave Three d a e (n-1);
pave Four c d b (n-1)]
else
let pen = Pen.circle in
let gb = Color.rgb 0. 1. 1. in
let gr = Color.rgb 1. 1. 0. in
let path = pathp ~style:jLine ~cycle:jLine [a;b;c] in
let color, segs =
match t with
| One -> gb, [a;c]::[a;b]::[]
| Two -> gb, [a;b]::[a;b]::[]
| Three -> gr, [a;c]::[c;b]::[]
| Four -> gr, [b;c]::[a;b]::[]
in
seq [Command.draw path; fill path ~color;
seq (List.map (fun l -> Command.draw ~pen (pathp ~style:jLine l)) segs)
]
let misc9 =
let a = cmp (0., 0.) in
let b = cmp (3., 0.) in
let d = Point.rotate 72. b in
let c = Point.add d (cmp (3.,0.)) in
seq [pave Three a c d 6; pave Four a b c 6]
(*
(*>> <> <> < proj i 0 j)
let up = square Color.yellow (fun i j -> proj i j 3)
let left = square Color.green (fun i j -> proj 0 (3 - i) j)
let misc12 =
seq [iter 0 2 (fun i -> iter 0 2 (right i));
iter 0 2 (fun i -> iter 0 2 (up i));
iter 0 2 (fun i -> iter 0 2 (left i));]
(*parse >> <> <> *)
let () = List.iter (fun (i,fig) ->
Metapost.emit ("misc"^(string_of_int i))
(Picture.scale (Num.bp 3.) fig))
[1,misc1;
2,misc2;
(* 3,misc3; chess10 can't be used by cairo*)
4,misc4;
5,misc5;
6,misc6;
7,misc7;
8,misc8;
9,misc9;
(* 10,misc10; Pen.square is not implemented *)
11,misc11;
12,misc12;
13,misc13;
14,misc14]
mlpost-0.8.2/examples/myocamlbuild.ml 0000664 0000000 0000000 00000007123 13060465153 0017676 0 ustar 00root root 0000000 0000000 open Ocamlbuild_plugin
(* open Command -- no longer needed for OCaml >= 3.10.2 *)
(* these functions are not really officially exported *)
let run_and_read = Ocamlbuild_pack.My_unix.run_and_read
let blank_sep_strings = Ocamlbuild_pack.Lexers.blank_sep_strings
let split s ch =
let x = ref [] in
let rec go s =
let pos = String.index s ch in
x := (String.before s pos)::!x;
go (String.after s (pos + 1))
in
try
go s
with Not_found -> !x
let split_nl s = split s '\n'
let before_space s =
try
String.before s (String.index s ' ')
with Not_found -> s
(* this lists all supported packages *)
let find_packages () =
List.map before_space (split_nl & run_and_read "ocamlfind list")
(* this is supposed to list available syntaxes, but I don't know how to do it. *)
let find_syntaxes () = ["camlp4o"; "camlp4r"]
(* ocamlfind command *)
let ocamlfind x = S[A"ocamlfind"; x]
let _ = dispatch begin function
| Before_options ->
(* by using Before_options one let command line options have an higher priority *)
(* on the contrary using After_options will guarantee to have the higher priority *)
(* override default commands by ocamlfind ones *)
Options.ocamlc := ocamlfind & A"ocamlc";
Options.ocamlopt := ocamlfind & A"ocamlopt";
Options.ocamldep := ocamlfind & A"ocamldep";
Options.ocamldoc := ocamlfind & A"ocamldoc";
Options.ocamlmktop := ocamlfind & A"ocamlmktop"
| After_rules ->
(* When one link an OCaml library/binary/package, one should use -linkpkg *)
flag ["ocaml"; "link"] & A"-linkpkg";
(* For each ocamlfind package one inject the -package option when
* compiling, computing dependencies, generating documentation and
* linking. *)
List.iter begin fun pkg ->
flag ["ocaml"; "compile"; "pkg_"^pkg] & S[A"-package"; A pkg];
flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S[A"-package"; A pkg];
flag ["ocaml"; "doc"; "pkg_"^pkg] & S[A"-package"; A pkg];
flag ["ocaml"; "link"; "pkg_"^pkg] & S[A"-package"; A pkg];
flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S[A"-package"; A pkg];
end (find_packages ());
(* Like -package but for extensions syntax. Morover -syntax is useless
* when linking. *)
List.iter begin fun syntax ->
flag ["ocaml"; "compile"; "syntax_"^syntax] & S[A"-syntax"; A syntax];
flag ["ocaml"; "ocamldep"; "syntax_"^syntax] & S[A"-syntax"; A syntax];
flag ["ocaml"; "doc"; "syntax_"^syntax] & S[A"-syntax"; A syntax];
flag ["ocaml"; "infer_interface"; "syntax_"^syntax] & S[A"-syntax"; A syntax];
end (find_syntaxes ());
(* The default "thread" tag is not compatible with ocamlfind.
Indeed, the default rules add the "threads.cma" or "threads.cmxa"
options when using this tag. When using the "-linkpkg" option with
ocamlfind, this module will then be added twice on the command line.
To solve this, one approach is to add the "-thread" option when using
the "threads" package using the previous plugin.
*)
flag ["ocaml"; "pkg_threads"; "compile"] (S[A "-thread"]);
flag ["ocaml"; "pkg_threads"; "link"] (S[A "-thread"]);
flag ["ocaml"; "pkg_threads"; "infer_interface"] (S[A "-thread"])
| _ -> ()
end
mlpost-0.8.2/examples/parse.mll 0000664 0000000 0000000 00000005637 13060465153 0016513 0 ustar 00root root 0000000 0000000 {
open Lexing
let togglescript =
"
hide mpost
show cairo png
show mps
show cairo ps
show cairo pdf
show cairo svg
"
}
let alpha_lower = ['a'-'z' ]
let alpha_upper = ['A'-'Z']
let alpha = ['a' - 'z' 'A'-'Z']
let digit = ['0'-'9']
let identifier = alpha_lower (alpha | digit | '\'' | '_')*
let blank = [' ' '\t' '\n' '\r' ]
rule scan = parse
| "<>" { Printf.printf "%s" togglescript; scan lexbuf }
| ">>" { Printf.printf "
"; scan lexbuf }
| "<<" (identifier as i)
{
Printf.printf
"\

" i;
Printf.printf
"\

" i;
Printf.printf
"\

" i;
Printf.printf
"\

" i;
Printf.printf
"\

" i;
Printf.printf
"\
" i;
Printf.printf "";
Printf.printf "" i;
Printf.printf "
";
scan lexbuf
}
| blank { scan lexbuf }
| eof { Printf.printf "%!" }
{
let _ =
let buf = Lexing.from_channel stdin in
scan buf
}
mlpost-0.8.2/examples/paths.ml 0000664 0000000 0000000 00000010304 13060465153 0016327 0 ustar 00root root 0000000 0000000 open Mlpost
open Point
open Path
open Command
open Dash
(*parse <> *)
let l = [0.,0.; 1., 0.; 0., 1.]
(*parse <> <> <> <> < draw ~pen (path ~scale:Num.cm [a])) [a;b;c]) ]
(*parse >> *)
let a = cmp (0., 0.)
let b = cmp (1., 0.)
let c = cmp (0., 1.)
(*html
*)
(*parse <> <> <> <
draw ~pen ~color (pathp ~style:jLine [a;b]))
[a,b;b,c;c,a] cl)
(*parse >> <> <> *)
let triangle =
path ~scale:Num.cm ~style:jLine ~cycle:jLine l
(*html
*)
(*parse <> <> *)
let pen = Pen.scale (Num.bp 2.) Pen.circle
(*html
*)
(*parse <> <> <
dotlabel ~pos (Picture.tex l) (Path.point i p))
[`Bot, "0", 0.; `Upleft, "1", 1. ;
`Lowleft, "2", 2. ; `Top, "3", 3. ; `Left, "4", 4. ]);
draw ~pen (subpath 1.3 3.2 p)]
(*parse >> <> *)
let _ =
List.iter (fun (name,fig) -> Metapost.emit name
(Picture.scale (Num.bp 3.) fig))
[ "paths1", paths1 ;
"paths2", paths2;
"paths3", paths3;
"paths4", paths4;
"paths5", paths5;
"paths6", paths6;
"paths7", paths7;
"paths8", paths8;
"paths9", paths9;
"paths10", paths10;
"paths11", paths11;
"paths12", paths12;
"paths13", paths13;
"paths14", paths14;
"paths15", paths15;
"paths16", paths16;
"paths17", paths17;
]
mlpost-0.8.2/examples/powered-by-caml.128x58.png 0000664 0000000 0000000 00000006125 13060465153 0021237 0 ustar 00root root 0000000 0000000 PNG
IHDR : O PLTEffffggjjnnppssuuwwxxzz}}dd^^\\NNffeeddccbbaa``^^]]\\[[ZZYYWWVVUUTTSSRRNNKKJJIIHHFFFFDDDDCCAA4hhggbbPPe33KKy>>g55kkjjY..``a33mmZZWWeeooppUUrr@##tto>>mmhhvvMMwwyy||RR||ppՀ}KKփՂׇׅ҃؉ss؋kkٍَ·W::bb[[۔֑__ܗttݙN66ޛݚaaޝ̑ߟߠٜᤤhh㪪ڣ֠tt㬬Ĕ䯯ssrXX沲ff絵ګ緷ɠxxeRR龾ɨťxffʆssָèĻӭî˨՚⧛ȼ cf tRNS fY bKGD pHYs H H Fk> vpAg : .w lIDATXř \U߬,88%
;+ǒx殚E&%ᅊiVZfZixT~ӴPS)\;3gofނ\h` 4k#-f,bQnX|mKt@w$D5<55 j&8D 'w6Qjc+1E`d okިε;έp& zqv{/H!
9 X
[Ih֠8jBhrptik @GО cMY h S ǚvLl 9@bF ΄c.V!yUg|5£>|# 8l-M6 1&