.bzrignore

+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

.gitignore

+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.*

AUTHORS

+Main Developers:
+  Jean-Christophe Filliâtre
+  Johannes Kanig
+  Stéphane Lescuyer
+
+Contributors:
+  Romain Bardou
+  Claude Marché
+  Florence Plateau
+  François Bobot

CHANGES

 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

INSTALL

 Dependencies:
-* You need Objective Caml 3.08.0 or higher to compile Mlpost.
-* You need Objective Caml 3.10.2 or higher to compile Mlpost with cairo
-  support; You also need the libraries bitstring, lablgtk2 and cairo.
-  check the output of ./configure to see if cairo has been selected.
+* 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)
+  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)

Makefile.in

@@ -24,7 +24,6 @@ datadir = @datadir@
 exec_prefix=@exec_prefix@
 BINDIR=@bindir@
 LIBDIR=@LIBDIR@
-USEOCAMLFIND=@USEOCAMLFIND@
 OCAMLFIND=@OCAMLFIND@
 OCAMLBUILDBIN=@OCAMLBUILD@
 
@@ -100,80 +99,41 @@ install-byte-contrib: install-byte-dot install-byte-lablgtk
 install-opt-contrib: install-opt-dot install-opt-lablgtk
 
 
-BCMA = $(addprefix $(BUILD), $(CMA))
+BCMA = $(addprefix $(BUILD), $(CMA) $(DLL))
 BCMXA = $(addprefix $(BUILD), $(CMXA) $(OBJ))
+BCMT = $(addprefix $(BUILD), mlpost.cmti mlpost.cmt)
 
-ifeq "@USEOCAMLFIND@" "no"
-install-byte:
-	mkdir -p $(LIBDIR)
-	cp -f $(BUILD)mlpost.cmi META $(BCMA) "$(LIBDIR)"
-
-install-opt:
-	mkdir -p $(LIBDIR)
-	cp -f $(BUILD)mlpost.cmi META $(BCMA) "$(LIBDIR)"
-	cp -f $(BUILD)mlpost$(LIBEXT) $(BCMXA) "$(LIBDIR)"
-
-install-byte-dot:
-	mkdir -p $(LIBDIR)_dot
-	cp -f contrib/dot/META "$(LIBDIR)_dot"
-	cp -f $(addprefix contrib/dot/_build/mlpost_dot,.cmi .cma) "$(LIBDIR)_dot"
-
-install-opt-dot:
-	mkdir -p $(LIBDIR)_dot
-	cp -f contrib/dot/META "$(LIBDIR)_dot"
-	cp -f $(addprefix contrib/dot/_build/mlpost_dot,.cmi .cma .cmxa $(LIBEXT)) "$(LIBDIR)_dot"
-
-ifeq "$(LABLGTK2)$(CAIROLABLGTK2)$(USEOCAMLFIND)" "yesyesyes"
-
-install-byte-lablgtk:
-	mkdir -p $(LIBDIR)_lablgtk
-	cp -f contrib/lablgtk/META "$(LIBDIR)_lablgtk"
-	cp -f $(addprefix contrib/lablgtk/_build/mlpost_lablgtk,.cmi .cma) "$(LIBDIR)_lablgtk"
-
-install-opt-lablgtk:
-	mkdir -p $(LIBDIR)_lablgtk
-	cp -f contrib/lablgtk/META "$(LIBDIR)_lablgtk"
-	cp -f $(addprefix contrib/lablgtk/_build/mlpost_lablgtk,.cmi .cma .cmxa $(LIBEXT)) "$(LIBDIR)_lablgtk"
-
-else
-install-byte-lablgtk:
-
-install-opt-lablgtk:
-
-endif
-
-else
 DESTDIR=-destdir $(LIBDIR:/mlpost=)
 
 install-byte:
 	$(OCAMLFIND) remove $(DESTDIR) mlpost
-	$(OCAMLFIND) install $(DESTDIR) mlpost $(BUILD)mlpost.cmi META $(BCMA)
+	$(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)
+	$(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)
+	   $(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))
+           $(addprefix contrib/dot/_build/mlpost_dot,.cmi .cma .cmxa $(LIBEXT) .cmt .cmti)
 
-ifeq "$(LABLGTK2)$(CAIROLABLGTK2)$(USEOCAMLFIND)" "yesyesyes"
+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)
+	   $(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))
+           $(addprefix contrib/lablgtk/_build/mlpost_lablgtk,.cmi .cma .cmxa $(LIBEXT) .cmt .cmti)
 else
 install-byte-lablgtk:
 
@@ -181,38 +141,22 @@ install-opt-lablgtk:
 
 endif
 
-endif
-
 install-byte-contrib: install-byte-dot install-byte-lablgtk
 
 
 install-bin:
-	mkdir -p $(BINDIR)
+	mkdir -p $(BINDIR) $(MANDIR)/man1
 	cp -f $(BUILD)$(TOOL) $(BINDIR)/mlpost
 	cp -f mlpost.1 $(MANDIR)/man1
 
-ifeq "@USEOCAMLFIND@" "no"
-uninstall: uninstall-contrib
-	rm -rf $(LIBDIR)
-	rm -f $(BINDIR)/mlpost
-	rm -f $(MANDIR)/mlpost
-else
 uninstall: uninstall-contrib
 	$(OCAMLFIND) remove $(DESTDIR) mlpost
 	rm -f $(BINDIR)/mlpost
 	rm -f $(MANDIR)/mlpost
-endif
 
-ifeq "@USEOCAMLFIND@" "no"
-uninstall-contrib:
-	rm -rf $(LIBDIR)/mlpost_lablgtk
-	rm -rf $(LIBDIR)/mlpost_dot
-else
 uninstall-contrib:
 	$(OCAMLFIND) remove $(DESTDIR) mlpost_dot
 	$(OCAMLFIND) remove $(DESTDIR) mlpost_lablgtk
-endif
-
 
 
 # export
@@ -321,4 +265,3 @@ config.status: configure
 
 configure: configure.in
 	autoconf
-

TODO

+1) BUGS
+(des erreurs ou des TODOs très importantes)
+==========
+* installation des fichiers Latex pour inclusion d'images
+* images et sortie postscript ?
+* Probleme d'alignement avec slideshow + externalimage
+
+
+2) TODO
+(améliorer du comportement interne, doc, des bugs pas très 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 boîte
+    - pouvoir choisir les flêches
+    - interface fonctionelle
+    - le supprimer en fait ? indiquer "deprecated" au dessus ?
+
+* Box : 
+  - foncteur WithBox pour faciliter l'accès aux boîtes nommées
+  - 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

_tags

@@ -12,3 +12,10 @@
 <test*> : use_unix, pkg_bitstring, pkg_cairo, use_cairo_bigarray
 <handbookgraphs.*> : use_unix, pkg_bitstring, pkg_cairo, use_cairo_bigarray
 <othergraphs.*> : use_unix, pkg_bitstring, pkg_cairo, use_cairo_bigarray
+<testsuite>: include
+<concrete_transform.ml> : syntax_macro, pkg_cairo
+<concrete_point.ml> : syntax_macro, pkg_cairo
+
+
+<mlpost.*> : use_freetype, use_libmlpost_ft
+<test_freetype.*> : use_freetype, use_libmlpost_ft, pkg_cairo, I(backend)

alphafill.mp

+% 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;
+

arrow.ml

@@ -24,16 +24,14 @@ let normalize = Point.normalize
 let neg = Point.scale (Num.bp (-1.))
 
 let direction_on_path f p =
-  Path.directionn (Num.multf f (Path.length p)) p
+  Path.direction (f *. Path.length p) p
 
 let point_on_path f p =
-  Path.pointn (Num.multf f (Path.length p)) p
+  Path.point (f *. Path.length p) p
 
 let subpath_01 f t p =
   let l = Path.length p in
-  let f = Num.multf f l in
-  let t = Num.multf t l in
-  Path.subpathn f t p
+  Path.subpath (f *. l) (t *. l) p
 
 (* Atoms *)
 
@@ -191,28 +189,38 @@ let draw ?(kind = triangle_full) ?tex ?(pos = 0.5) ?anchor path =
   Command.seq (lines @ belts @ labels)
 
 (* Instances *)
-
-let point_to_point ?kind ?tex ?pos ?anchor ?outd ?ind a b =
+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
-  draw ?kind ?tex ?pos ?anchor (Path.pathk [Path.knotp ?r a; Path.knotp ?l b])
+  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 ?outd ?ind a b =
-  draw ?kind ?tex ?pos ?anchor (Box.cpath ?outd ?ind a b)
+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 ?outd ?ind a b =
-  draw ?kind ?tex ?pos ?anchor (Box.cpath_left ?outd ?ind 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 ?outd ?ind a b =
-  draw ?kind ?tex ?pos ?anchor (Box.cpath_right ?outd ?ind 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 a b =
+let simple_point_point ?style ?outd ?ind ?sep a b =
   let r,l = outd, ind in
-  pathk ?style [knotp ?r a; knotp ?l b]
+  Box.strip ?sep (pathk ?style [knotp ?r a; knotp ?l b])
 
 
 (*let normalize p =

backend/_tags

@@ -7,3 +7,7 @@
 
 
 <*.cmx> : for-pack(Mlpost)
+
+
+<ml_mlpost_ft.c> : include_freetype
+<mlpost_ft.*>    : pkg_cairo
\ No newline at end of file

backend/draw.ml

@@ -17,14 +17,11 @@
 open Point_lib
 module S = Spline_lib
 
-module Cairo_device = Dev_save.Dev_load(Dvicairo.Cairo_device)
-
 let draw_tex cr tex =
   Cairo.save cr;
   Cairo.transform cr tex.Gentex.trans;
-  Cairo_device.replay false tex.Gentex.tex
-  {Dvicairo.pic = cr;new_page = (fun () -> assert false);
-   x_origin = 0.; y_origin = 0.};
+  Dvicairo.draw
+    {Dvicairo.pic = cr; x_origin = 0.; y_origin = 0.} tex.Gentex.tex;
   Cairo.restore cr
   (*;Format.printf "Gentex : %a@." print tex*)
 
@@ -129,13 +126,11 @@ struct
         Cairo.clip cr;
         draw_aux cr com;
         Cairo.restore cr
-    | ExternalImage (filename,height,width) ->
+    | 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
-        let iwidth = float_of_int (Cairo.image_surface_get_width img) in
-        let iheight = float_of_int (Cairo.image_surface_get_height img) in
-        Cairo.scale cr (width/.iwidth) (height/.iheight);
         Cairo.set_source_surface cr img 0. 0.;
         Cairo.paint cr;
         Cairo.restore cr

backend/dvicairo.ml

@@ -16,11 +16,10 @@
 
 open Format
 open Dviinterp
-
+open Mlpost_ft
 
 
 type multi_page_pic = {pic :Cairo.t;
-            new_page : unit -> unit;
                        x_origin : float;
                        y_origin : float
                       }
@@ -28,58 +27,26 @@ type multi_page_pic = {pic :Cairo.t;
 let conversion = 0.3937 *. 72.
 let point_of_cm cm = conversion *. cm
 
-let debug = ref false
-let specials = ref false
-let info = ref false
-
-module Cairo_device : dev with type arg = multi_page_pic with type cooked
-  = unit =
-struct
-  type arg = multi_page_pic
-  type t = { arg : arg;
-             doc : Dvi.t}
-             (*fonts :(string,Cairo_ft.font_face * Cairo_ft.ft_face) 
-               Hashtbl.t*)
-  type cooked = unit
-
-  let ft = Cairo_ft.init_freetype ()
-
 let fonts_known = Hashtbl.create 30
 
 let find_font font =
-    let font_name = Fonts.tex_name font in
+  let font_name = font.Fonts.glyphs_tag in
   try Hashtbl.find fonts_known font_name
   with Not_found ->
-      if !debug then printf "Cairo : Loading font %s@." font_name;
-      let filename = Fonts.glyphs_filename font in
-      if !debug then printf "Trying to find font at %s...@." filename;
-      let face = Cairo_ft.new_face ft filename in
-      let f =Cairo_ft.font_face_create_for_ft_face face 0,face in
+    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 () = 
-    Hashtbl.iter (fun _ (_,x) -> Cairo_ft.done_face x) fonts_known;
-    Cairo_ft.done_freetype ft
-
-  let new_document arg doc = 
-    let first_page = ref true in
-    {arg = {arg with new_page = 
-         (fun () -> if !first_page then first_page := false 
-          else arg.new_page ());
-         x_origin = point_of_cm arg.x_origin;
-         y_origin = point_of_cm arg.y_origin};
-     doc = doc}
-
-  let new_page s = 
-    s.arg.new_page ()
+let clean_up () = ()
 
 let set_source_color pic = function
   | RGB(r,g,b) ->
-        if !debug then
+    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 !debug then
+    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\
@@ -90,121 +57,71 @@ struct
 
 
 let fill_rect s dinfo x1 y1 w h =
-    let x1 = point_of_cm x1 +. s.arg.x_origin
-    and y1 = point_of_cm y1 +. s.arg.y_origin
+  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 !debug then
+  if Defaults.get_debug () then
     printf "Draw a rectangle in (%f,%f) with w=%f h=%f@." x1 y1 w h;
-    Cairo.save s.arg.pic;
-    set_source_color s.arg.pic dinfo.Dviinterp.color;
-    Cairo.rectangle s.arg.pic x1 y1 w h;
-    Cairo.fill s.arg.pic;
-    Cairo.restore s.arg.pic
-
-  let draw_char s dinfo font char x y = 
-    let f = fst (find_font font) in
-    let char = Fonts.glyphs_enc font (Int32.to_int char)
-    and x = point_of_cm x +. s.arg.x_origin
-    and y = point_of_cm y +. s.arg.y_origin
-    and ratio = Fonts.scale font conversion in
-    if !debug then begin
-      let name = Fonts.tex_name font in
+  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) of %s in (%f,%f) x%f@." 
-          char (Char.chr char) name x y ratio;
+      printf "Draw the char %i(%c) in (%f,%f) x%f@."
+        char (Char.chr char) x y ratio;
     with _ ->
-        printf "Draw the char %i of %s  in (%f,%f) x%f@." char name x y ratio
+      printf "Draw the char %i in (%f,%f) x%f@." char x y ratio
   end;
-        
-    Cairo.save s.arg.pic;
-    set_source_color s.arg.pic dinfo.Dviinterp.color;
-    Cairo.set_font_face s.arg.pic f ;
-    Cairo.set_font_size s.arg.pic ratio;
+  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 Fonts.slant font with
-      | Some a when !info -> 
-          printf "slant of %f not used for %s@." a (Fonts.tex_name font)
+  (match font.Fonts.slant with
+    | Some a when Defaults.get_verbosity () ->
+      printf "slant of %f not used@." a
     | Some _ | None -> ());
-    (match Fonts.extend font with
-      | Some a when !info -> 
-          printf "extend of %f not used for %s@." a (Fonts.tex_name font)
+  (match font.Fonts.extend with
+    | Some a when Defaults.get_debug () ->
+      printf "extend of %f not used@." a
     | Some _ | None -> ());
-    Cairo.show_glyphs s.arg.pic 
+  Cairo.show_glyphs s.pic
     [|{Cairo.index = char;
        Cairo.glyph_x = x;
        Cairo.glyph_y = y}|];
-    Cairo.stroke s.arg.pic;
-    Cairo.restore s.arg.pic
+  Cairo.stroke s.pic;
+  Cairo.restore s.pic
 
-  let specials s info xxx x y =
-    if !debug || !specials then
+let _specials s info xxx x y =
+  if Defaults.get_debug () then
     printf "specials : \"%s\" at (%f,%f)@." xxx x y
 
-  let end_document s = 
-    ()
-end
-
-
-(*
-let create_window () = 
-    let w = GWindow.window ~title:"Cairo Text API" () in
-    ignore (w#connect#destroy GMain.quit);
-    if !debug then
-      printf "Create the picture@.";
-    let pixmap = GDraw.pixmap ~width:(int_of_float width)
-  ~height:(int_of_float height) ~window:w () in
-    pixmap
-
-let show_gtk doc pixmap window = 
-    let height = point_of_cm (Dvi.get_height_cm doc) +. 2. *. !margin in
-    let width = point_of_cm (Dvi.get_width_cm doc) +. 2. *. !margin in
-    if !info then printf "height = %f, width = %f@." height width;
-    if !debug then
-      printf "Create the window@.";
-
-    let cr = Cairo_lablgtk.create pixmap#pixmap in
-    Cairo.set_source_rgb cr 1. 1. 1. ;
-    Cairo.set_line_width cr 1. ;
-    Cairo.show_page cr ;
-    Cairo.fill cr;
-    {output = arg;
-     new_page =  (fun () -> 
-                    if !debug then
-                      printf "Display@.";
-                    ignore (GMisc.pixmap pixmap ~packing:window#add ());
-                    window#show () ;
-                    GMain.main ());
-     clean_up = (fun () -> ());
-     pic = cr;
-     doc = doc}
-    *)
-
-let create_png _ _ _ _ _ _ = ()
-let create_gtk _ _ _ _ _ _ = ()
-
-let create create_surface height width x_origin y_origin 
-    (interp_doc: multi_page_pic -> unit) out_file =
-  let height = point_of_cm height and width = point_of_cm width in
-  if !info 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
-  interp_doc {pic = cr;
-   new_page = (fun () -> 
-                 if !info then printf "Show_page ...@.";
-                 Cairo.show_page cr;
-              );
-   x_origin = x_origin;
-   y_origin = y_origin
-   (*fonts = Hashtbl.create 10*)};
-    if !info then printf "Clean up surface_finish ...@.";
-  Cairo.surface_finish s;
-  if !info then printf "Clean up close file ...@.";
-  close_out oc
-
-let create_ps = create Cairo_ps.surface_create_for_channel
-
-let create_pdf = create Cairo_pdf.surface_create_for_channel
-
-let create_svg = create Cairo_svg.surface_create_for_channel
+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
+
+
+

backend/dvicairo.mli

+type multi_page_pic = {pic :Cairo.t;
+                       x_origin : float;
+                       y_origin : float
+                      }
+
+val draw : multi_page_pic -> Dviinterp.command list -> unit

backend/icairost.ml

@@ -16,17 +16,16 @@
 
 open Point_lib
 open Format
-let info = ref false
 
 let create create_surface out_file (draw:Cairo.t -> unit) height width =
-  if !info then printf "height = %f, width = %f@." 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 !info then printf "Clean up surface_finish ...@.";
+  if Defaults.get_debug () then printf "Clean up surface_finish ...@.";
   Cairo.surface_finish s;
-  if !info then printf "Clean up close file ...@.";
+  if Defaults.get_debug () then printf "Clean up close file ...@.";
   close_out oc
 
 let rec iter_after f after = function
@@ -53,7 +52,7 @@ 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 =
-    LookForTeX.commandpicl_error (error_replace_by_tex msg_error) figs in
+    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
@@ -98,13 +97,9 @@ let emit_png fname fig = emit_gen
 
 let emit_cairo cairo (width,height) fig =
   (*Compute.clear (); LookForTeX.clear ();*)
-  let fig = LookForTeX.commandpic fig in
+  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
-
-
-let set_verbosity b =
-  Dvicairo.specials := b

backend/libmlpost_ft.clib

+ml_mlpost_ft.o
\ No newline at end of file

backend/lookForTeX.ml

-(**************************************************************************)
-(*                                                                        *)
-(*  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.                  *)
-(*                                                                        *)
-(**************************************************************************)
-
-(* look for some piece of TeX *)
-
-open Types
-open Hashcons
-
-let num_memoize = Hashtbl.create 50
-let point_memoize = Hashtbl.create 50
-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 num_memoize;
-  Hashtbl.clear point_memoize;
-  Hashtbl.clear metapath_memoize;
-  Hashtbl.clear path_memoize;
-  Hashtbl.clear picture_memoize;
-  Hashtbl.clear command_memoize
-
-let memoize f memoize =
-  fun acc arg -> 
-    try
-      Hashtbl.find memoize arg.tag;
-      acc
-    with
-        Not_found -> 
-          Hashtbl.add memoize arg.tag ();
-          f acc arg.node
-
-let option_compile f acc = function
-  | None -> acc
-  | Some obj -> f acc obj
-
-let rec num' acc = function
-  | F f -> acc
-  | NXPart p | NYPart p -> point acc p
-  | NAdd(n1,n2) | NSub(n1,n2) | NMult (n1,n2)
-  | NDiv (n1,n2) | NMax (n1,n2) | NMin (n1,n2)
-  | NGMean (n1,n2) -> num (num acc n1) n2
-  | NLength p -> path acc p
-  | NIfnullthenelse (n,n1,n2) -> num (num (num acc n) n1) n2
-
-and num acc = memoize num' num_memoize acc
-and point' acc = function
-  | PTPair (f1,f2) -> num (num acc f1) f2
-  | PTPointOf (f,p) | PTDirectionOf (f,p)-> path (num acc f) p
-  | PTAdd (p1,p2) |PTSub (p1,p2) -> point (point acc p1) p2
-  | PTMult (f,p) -> point (num acc f) p
-  | PTRotated (_,p) -> point acc p
-  | PTPicCorner (pic,_) -> commandpic acc pic
-  | PTTransformed (p,tr) -> point (transform acc tr) p
-and point acc = memoize point' point_memoize acc
-and knot acc k = 
-  match k.Hashcons.node with
-    |{ knot_in = d1 ; knot_p = p ; knot_out = d2 } ->
-       direction (direction (point acc p) d1) d2
-and joint acc j =
-  match j.Hashcons.node with
-      | JControls (p1,p2) -> point (point acc p1) p2
-      | JLine|JCurve|JCurveNoInflex|JTension _ -> acc
-and direction acc d = 
-  match d.Hashcons.node with
-    | Vec p -> point acc p
-    | Curl _ | NoDir -> acc
-and metapath' acc = function
-  | MPAConcat (pa,j,p) -> metapath (knot (joint acc j) pa) p
-  | MPAAppend (p1,j,p2) -> metapath (metapath (joint acc j) p1) p2
-  | MPAKnot k -> knot acc k
-  | MPAofPA p -> path acc p
-and metapath acc = memoize metapath' metapath_memoize acc
-and path' acc = function
-  | PAofMPA p -> metapath acc p
-  | MPACycle (d,j,p) -> direction (metapath (joint acc j) p) d
-  | PATransformed (p,tr) -> path (transform acc tr) p
-  | PACutAfter (p1,p2) |PACutBefore (p1,p2) -> path (path acc p1) p2
-  | PASub (f1,f2,p) -> num (num (path acc p) f1) f2
-  | PABBox p -> commandpic acc p
-  | PABuildCycle p -> List.fold_left path acc p
-  | PAUnitSquare | PAQuarterCircle | PAHalfCircle | PAFullCircle -> acc
-and path acc = memoize path' path_memoize acc
-and picture acc arg =
-  try
-    Hashtbl.find picture_memoize arg.tag;
-    acc
-  with
-      Not_found -> 
-        Hashtbl.add picture_memoize arg.tag ();
-        match arg.node with
-          | PITransformed (p,tr) -> commandpic (transform acc tr) p
-          | PITex tex -> (arg,tex)::acc
-          | PIClip (pic,pth) -> commandpic (path acc pth) pic
-and transform acc t =
-  match t.Hashcons.node with
-    | TRRotated _ -> acc
-    | TRScaled f | TRSlanted f | TRXscaled f | TRYscaled f -> num acc f
-    | TRShifted p | TRZscaled p | TRRotateAround (p,_)-> point acc p
-    | TRReflect (p1,p2) -> point (point acc p1) p2
-    | TRMatrix p -> 
-        num (num (num (num (num (num acc p.x0) p.y0) p.xx) p.xy) p.yx) p.yy
-and dash acc d =
-  match d.Hashcons.node with
-    | DEvenly | DWithdots -> acc
-    | DScaled (n,d) -> dash (num acc n) d
-    | DShifted (p,d) -> point (dash acc d) p
-    | DPattern l -> List.fold_left dash_pattern acc l
-and dash_pattern acc o =
-  match o.Hashcons.node with
-    | On f | Off f -> num acc f
-and command' acc = function
-  | CDraw (p, b) -> 
-      let {color = _; pen = pe; dash = dsh} = b.Hashcons.node in
-      path ((option_compile pen) ((option_compile dash) acc dsh) pe) p
-  | CFill (p,_) -> path acc p
-  | CDotLabel (pic,_,pt) | CLabel (pic,_,pt) -> commandpic (point acc pt) pic
-  | CExternalImage _ -> acc
-and pen acc p = 
-  match p.Hashcons.node with
-    | PenCircle | PenSquare -> acc
-    | PenFromPath p -> path acc p
-    | PenTransformed (p,tr) -> pen (transform acc tr) p
-
-and command acc = memoize command' command_memoize acc
-
-and commandpic acc p =
-  match p.Hashcons.node with
-  | Picture p -> picture acc p
-  | Command c -> command acc c
-  | Seq l -> List.fold_left commandpic acc l
-
-let compile_tex l =
-  let tags,texs = List.split l in
-  let texs = Gentex.create !Compute.prelude texs in
-  List.iter2 (fun tag tex -> Hashtbl.add 
-                Compute.picture_memoize tag.tag (Picture_lib.tex tex))
-    tags texs
-
-let ct_aux f = fun arg -> compile_tex (f [] arg)
-let ct_auxl f = fun argl -> compile_tex (List.fold_left f [] argl)
-
-let commandl arg = ct_auxl command arg; List.map Compute.command arg
-let commandpicl arg = ct_auxl commandpic arg; List.map Compute.commandpic arg
-let numl arg = ct_auxl num arg; List.map Compute.num arg
-let pointl arg = ct_auxl point arg; List.map Compute.point arg
-let pathl arg = ct_auxl path arg; List.map Compute.path arg
-let metapathl arg = ct_auxl metapath arg; List.map Compute.metapath arg
-let picturel arg = ct_auxl picture arg; List.map Compute.picture arg
-
-let commandl_error ferror arg = ct_auxl command arg; 
-  List.map (ferror Compute.command) arg
-let commandpicl_error ferror arg = ct_auxl commandpic arg; 
-  List.map (ferror Compute.commandpic) arg
-let numl_error ferror arg = ct_auxl num arg; 
-  List.map (ferror Compute.num) arg
-let pointl_error ferror  arg = ct_auxl point arg; 
-  List.map (ferror Compute.point) arg
-let pathl_error ferror  arg = ct_auxl path arg; 
-  List.map (ferror Compute.path) arg
-let metapathl_error ferror  arg = ct_auxl metapath arg; 
-  List.map (ferror Compute.metapath) arg
-let picturel_error ferror arg = ct_auxl picture arg; 
-  List.map (ferror Compute.picture) arg
-
-
-
-let compute_nums () =
-  let l = ref [] in
-  (fun n -> l:= num !l n),(fun () -> compile_tex !l;l:=[])
-
-
-let commandpic arg = ct_aux commandpic arg; Compute.commandpic arg
-let command arg = ct_aux command arg; Compute.command arg
-let num arg = ct_aux num arg; Compute.num arg
-let point arg = ct_aux point arg; Compute.point arg
-let path arg = ct_aux path arg; Compute.path arg
-let metapath arg = ct_aux metapath arg; Compute.metapath arg
-let picture arg = ct_aux picture arg; Compute.picture arg
-let transform arg = ct_auxl transform arg; 
-  List.fold_left (fun acc t -> Matrix.multiply acc (Compute.transform t)) 
-    Matrix.identity arg

backend/ml_mlpost_ft.c

+
+
+#include <assert.h>
+#include <string.h>
+
+#define CAML_NAME_SPACE
+
+#include <caml/mlvalues.h>
+
+#include <ft2build.h>
+#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));
+}