mlpost-0.8.1/0000755000443600002640000000000011365367167012220 5ustar kanigdemonsmlpost-0.8.1/radar.ml0000644000443600002640000002042211365367177013644 0ustar kanigdemons(**************************************************************************) (* *) (* 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 Command open Path open Num open Color open Types open Infix (* Module implémentant une file avec deux listes *) module Q = Misc.Q let scale_radius r l= List.map (fun (x,y) -> (multf x r,multf y r)) l let scale_radius_2 r l = List.map (scale_radius r) l (* Calcule la liste des max des ième éléments de chaque liste *) let maxlist =function |ml::ll-> List.fold_left (List.map2 max) ml ll |[]-> failwith "Empty list" type direction = Horizontal | Vertical | Other (* Calcule les 2 points à distance d de la droite de coefficient directeur a2_equ perpendiculaire à l'axe de tc *) let rec make_paths a2_equ tc d sens acc radius = match tc with |(absc,ordo)::res -> let (absc,ordo) = (multf absc radius,multf ordo radius) in begin match sens with | Vertical -> (* Le long de l'axe des ordonnées *) let absc2 = (+/) absc d in let absc3 = (-/) absc d in make_paths a2_equ res d sens ([(absc2,ordo);(absc3,ordo)]::acc) radius | Horizontal -> (* Le long de l'axe des abscisses *) let ordo2 = (+/) ordo d in let ordo3 = (-/) ordo d in make_paths a2_equ res d sens ([(absc,ordo2);(absc,ordo3)]::acc) radius | Other -> let b2_equ = (-/) ordo (( *./) a2_equ absc) in let co = 1. /. (sqrt (1.+.a2_equ*.a2_equ)) in let angle = if a2_equ>0. then 360 - (int_of_float ((acos co)*.180./.pi)) else int_of_float (acos(co)*.180./.pi) in let absc2 = (+/) absc (( *./) (cos ((float angle)*.2.*.pi/.360.)) d) in let ordo2 = (+/) (( *./) a2_equ absc2) b2_equ in let angle2 = (angle+180) mod 360 in let absc3 = (+/) absc (( *./) (cos ((float angle2)*.2.*.pi/.360.)) d) in let ordo3 = (+/) (( *./) a2_equ absc3) b2_equ in make_paths a2_equ res d sens ([(absc2,ordo2);(absc3,ordo3)]::acc) radius end |[]-> acc (* Dessine les ticks le long de l'axe passé en paramètre *) let draw_ticks ticks coords m d radius= let (x,y) = List.hd (List.rev coords) in let rec ticks_coords acc ticks i x y m = if i<=m then ticks_coords ((x*.i/.m,y*.i/.m)::acc) ticks (i+.ticks) x y m else acc in let tc = ticks_coords [] ticks ticks x y m in let x = if (abs_float x < 10e-4) then 0. else x in let y = if (abs_float y < 10e-4) then 0. else y in let a2_equ,sens = if x=0. then 0.,Vertical else if y=0. then 0.,Horizontal else ((-.x)/.y),Other in let p = make_paths a2_equ tc d sens [] radius in iterl (fun x -> draw (pathn x)) p (* *) let draw_label pt lab radius = let (x,y) = List.hd (List.rev pt) in let angl = (acos (x /. (sqrt (x*.x +. y*.y))))*.180./.pi in let angle = if y<0. then 360.-.angl else angl in let placement = if ((angle>315. && angle<360.) || (angle>=0. && angle<=45.)) then `East else if (angle>45. && angle<=135.) then `North else if (angle>135. && angle<=225.) then `West else `South in Command.label ~pos:placement (Picture.tex lab) (Point.pt (multf x radius, multf y radius)) (* Dessine le radar vide *) let rec draw_skeleton acc ?label ticks lmax skltn d radius= let label = match label with |None -> [] |Some i -> i in match skltn,lmax,label with |x::res,m::lm,lab::labl -> let x2= scale_radius radius x in draw_skeleton ((draw (pathn x2)) ++(draw_ticks ticks x m d radius) ++(draw_label x lab radius)++acc) ~label:labl ticks lm res d radius |x::res,m::lm,[] -> let x2= scale_radius radius x in draw_skeleton ((draw (pathn x2)) ++(draw_ticks ticks x m d radius)++acc) ~label:[] ticks lm res d radius |[],[],[] -> acc |_,_,_-> failwith "Different list sizes" (* Fabrique une liste contenant les coordonnées des axes du radar *) let empty_radar_coords nbr = let delta = 360. /. (float nbr) in let rec empty_radar acc nb diff angle = if nb>0 then empty_radar ([(0.,0.);(cos (angle*.2.*.pi/.360.), sin (angle*.2.*.pi/.360.) )]::acc) (nb-1) diff (angle+.diff) else List.rev acc in empty_radar [] nbr delta 0. (* Fabrique la liste des coordonnées correspondant à chaque valeur *) let list_coord lmax l skeleton = let rec fct lmax l skeleton acc = match lmax,l,skeleton with |x::res,y::res2,z::res3 -> let (z1,z2) = List.hd (List.rev z) in let x_coord = z1*.y/.x in let y_coord = z2*.y/.x in fct res res2 res3 ((x_coord,y_coord)::acc) |[],[],[] -> List.rev acc |_,_,_ -> failwith "Different list sizes" in fct lmax l skeleton [] (* Fabrique un radar associé au squelette de radar passé en paramètre *) let radar color lmax l skeleton pen fill stl radius = let coords = scale_radius radius (list_coord lmax l skeleton) in let rec dots acc f c = match c with |x::res -> let col = if f then Color.black else color in let cmd = draw ~pen:(Pen.scale (bp 3.) pen) ~color:col (pathn [x]) in dots (cmd++acc) f res |[]->acc in let dots_cmd = dots nop fill coords in let clr = if fill then Color.black else color in let path_cmd = draw (pathn ~style:jLine ~cycle:jLine coords) ~pen ~color:clr ~dashed:stl in let path_filled = if fill then (Command.fill ~color:color (pathn ~style:jLine ~cycle:jLine coords)) else nop in path_filled++path_cmd++dots_cmd let default_radius = bp (100.) let default_style = [(Dash.pattern [Dash.on (bp 1.);Dash.off (bp 0.)])] let default_pen = Pen.scale (bp 0.5) Pen.circle let init radius ?scale l= let ticks_size = divf (multf 3. radius) 100. in let lesmax = match scale with |None -> maxlist l |Some l -> l in let skeleton = match l with |x::_ -> empty_radar_coords (List.length x) |[] -> failwith "No data" in ticks_size,lesmax,skeleton (* Fabrique des radars empilés *) let stack ?(radius=default_radius) ?(color=[black]) ?(pen=default_pen) ?(style=default_style) ?(ticks=1.) ?label ?scale l = let ticks_size,lesmax,skeleton = init radius ?scale l in let rec radar_list col stl maxi li skltn acc = match li,col,stl with |x::res,cq,sq -> let c,cres = Q.pop cq in let s,sres = Q.pop sq in radar_list (Q.push c cres) (Q.push s sres) maxi res skltn ((radar c maxi x skltn pen false s radius)++acc) |[],cq,sq-> acc in Picture.make ((draw_skeleton nop ?label ticks lesmax skeleton ticks_size radius) ++(radar_list (Q.of_list color) (Q.of_list style) lesmax l skeleton nop)) (* Fabrique des radars comparatifs, renvoie la liste de Pictures représentant chaque radar *) let compare ?(radius=default_radius) ?(color=[black]) ?(fill=false) ?(pen=default_pen) ?(style=default_style) ?(ticks=1.) ?label ?scale l = let ticks_size,lesmax,skeleton = init radius ?scale l in let rec build_pictures skltn col stl maxi li tcks acc = match li,col,stl with |x::res,cq,sq -> let c,cres = Q.pop cq in let s,sres = Q.pop sq in let r = radar c maxi x skltn pen fill s radius in let sk = draw_skeleton nop ?label tcks maxi skltn ticks_size radius in let pic = Picture.make (r++sk) in build_pictures skltn (Q.push c cres) (Q.push s sres) maxi res tcks (pic::acc) |[],cq,sq-> List.rev acc in build_pictures skeleton (Q.of_list color) (Q.of_list style) lesmax l ticks [] mlpost-0.8.1/mlpost.10000644000443600002640000000575711365367177013637 0ustar kanigdemons.\" Hey, EMACS: -*- nroff -*- .TH MLPOST 1 "August 2009" .\" Please adjust this date whenever revising the manpage. .SH NAME mlpost \- wrapper around OCaml and Metapost for the Mlpost library .SH SYNOPSIS .B mlpost .RI [options] " files"... .SH DESCRIPTION .PP \fBmlpost\fP is a program that compiles OCaml files to PostScript or PDF files using the Mlpost library. .SH OPTIONS .TP .B \-pdf Generate .mps files (default) .TP .B \-mp Generate .mp files .TP .B \-png Generate .png files .TP .B \-ps Generate .1 files .TP .B \-latex Scan the LaTeX prelude .TP .B \-eps Generate encapsulated postscript files .TP .B \-xpdf WYSIWYG mode using xpdf remote server (the name of the remote server is "mlpost") .TP .B \-v Be a bit more verbose. Otherwise nothing is printed except in case of error. .TP .B \-ocamlbuild Use ocamlbuild to compile .TP .B \-native Compile to native code .TP .B \-ccopt "" Pass to the Ocaml compiler .TP .B \-execopt "" Pass to the compiled program .TP .B \-version Print Mlpost version and exit .TP .B \-no-magic Do not parse mlpost options, do not call Metapost.dump .TP .B \-depend output dependency lines in a format suitable for the make(1) utility .TP .B \-contrib "" compile with the specified contrib .TP .B \-dumpable output one name of dumpable file by line. So it print all the figures which will be created by the .ml file. .TP .B \-get-include-compile {cmxa|cma|dir|file} output the libraries which are needed by the library Mlpost if you want not to use the mlpost tool : .IP \- cmxa print the needed cmxa file (opt version) \- cma print the needed cma file (byte version) \- dir print the directories needed to be include \- file print the file name inside this directory without extension .TP .B \-compile-name Keep the compiled version of the .ml file and name it . .TP .B \-dont-execute Don't execute the mlfile. So mlpost generates no figures. With this option you can check that a file compile without wasting time to generate the figures. The options -dont-execute and -compile-name can be used in conjunction to create a program which generates some figures according to some command line options. .TP .B \-dont-clean Don't remove intermediates files. The metapost backend use some intermediates files which are removed without this option. .TP .B \-cairo Use the cairo backend instead of metapost .TP .B \-t1disasm Set the program used to decrypt PostScript Type 1 font, only with cairo (default built-in one). This option will disappear soon. .TP .B \-help, \-\-help Display the list of options .SH SEE ALSO .BR mpost (1), .BR ocamlc (1), .BR xpdf (1). .br .SH AUTHOR Mlpost was written by Romain Bardou, François Bobot, Johannes Kanig, Stéphane Lescuyer and Jean-Christophe Filliâtre. .PP This manual page was written by Stéphane Glondu and completed by the Mlpost authors for the Debian project (but may be used by others). mlpost-0.8.1/mlpost_nolablgtk.odocl0000644000443600002640000000002111365367177016607 0ustar kanigdemonsMlpost Mlpost_dotmlpost-0.8.1/scan_prelude.mll0000644000443600002640000000305311365367177015374 0ustar kanigdemons(**************************************************************************) (* *) (* 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 Lexing let buffer = Buffer.create 1024 } (* scan the main LaTeX file to extract its prelude *) rule scan = parse | "\\%" as s { Buffer.add_string buffer s; scan lexbuf } | "%" [^'\n']* '\n' { Buffer.add_char buffer '\n'; scan lexbuf } | _ as c { Buffer.add_char buffer c; scan lexbuf } | "\\begin{document}" { Buffer.contents buffer } | eof { Buffer.contents buffer } mlpost-0.8.1/tree.ml0000644000443600002640000002155511365367177013522 0ustar kanigdemons(**************************************************************************) (* *) (* 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 Command open Helpers open Path open Num open Num.Infix type arrow_style = Directed | Undirected type edge_style = Straight | Curve | Square | HalfSquare type 'a tree = Node of 'a * ('a tree list) type extend = (Num.t * Num.t) list type 'a positionedtree = ('a * Num.t * Num.t) tree let movetree (Node((label,x,y),subtrees)) dx = Node((label,((+/) x dx),y),subtrees) let moveextend (e:extend) (x:Num.t) : extend = List.map (fun (p,q) -> (((+/) p x),((+/) q x))) e let rec merge a1 a2 = match a1,a2 with |[],rt -> rt |lt,[] -> lt |(l,_)::t1,(_,r)::t2 -> (l,r)::(merge t1 t2) let mergelist l = List.fold_right merge l [] let rec fit cs (a1:extend) (a2: extend) : Num.t = match a1,a2 with |(_,r)::t1,(l,_)::t2 -> maxn (fit cs t1 t2) ((+/) ((-/) r l) cs) |_ -> bp 0. let fitlistl cs (l: extend list) :(Num.t list) = let rec fitlistaux acc li = match li with |[] -> [] |e::res -> let x = fit cs acc e in x::(fitlistaux (merge acc (moveextend e x)) res) in fitlistaux [] l let fitlistr cs (l: extend list) :(Num.t list) = let rec fitlistaux acc li = match li with |[] -> [] |e::res -> let x = neg (fit cs e acc) in x::(fitlistaux (merge (moveextend e x) acc) res) in List.rev (fitlistaux [] (List.rev l)) let mean x y = ((//) ((+/) x y) (bp 2.)) let fitlist cs (l: extend list) :(Num.t list) = List.map2 mean (fitlistl cs l) (fitlistr cs l) let bfs t = let rec bfs_aux lesmax m current next = match current with |[] -> if next=[] then List.rev (m :: lesmax) else bfs_aux (m::lesmax) (bp 0.) next [] |Node(x,tl)::cl -> let ((b,_),_,_) = x in let m = maxn m (Box.height b) in bfs_aux lesmax m cl (tl@next) in bfs_aux [] (bp 0.) [t] [] let rec dfs lesmax t = match t,lesmax with |Node((b,x,_),tl),m::mres -> Node((b,x,m),List.map (dfs mres) tl) |_,[]-> failwith "impossible" type node_info = { ls:Num.t; cs:Num.t; arrow_style:arrow_style; edge_style:edge_style; stroke:Color.t option; pen: Pen.t option; sep: Num.t option; lab: (Command.position * Picture.t) list option; } let dummy_info = { ls = zero; cs = zero; arrow_style = Directed; edge_style = Straight; stroke = None; pen = None; sep = None; lab = None } let design tree = let rec designaux (Node((b,ni) as label, subtrees)) = let trees,extends = List.split (List.map designaux subtrees) in let positions = fitlist ni.cs extends in let ptrees = List.map2 movetree trees positions in let pextends = List.map2 moveextend extends positions in let w = divf (Box.width b) 2. in let resultextend = (neg w, w) :: mergelist pextends in let resulttree = Node((label,bp 0.,bp 0.),ptrees) in resulttree,resultextend in let thetree = fst (designaux tree) in let maxlistheight = bfs thetree in dfs maxlistheight thetree (* drawing *) 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 = pathk ?style [knotp ?r (Box.ctr a); knotp ?l (Box.north b)] in strip ?sep (cut_before (Box.bpath a) p) let box_arrow ?color ?brush ?pen ?dashed ?style ?outd ?ind ?sep a b = Arrow.simple ?color ?brush ?pen ?dashed (cpath ?style ?outd ?ind ?sep a b) let box_line ?color ?brush ?pen ?dashed ?style ?outd ?ind ?sep a b = draw ?color ?brush ?pen ?dashed (cpath ?style ?outd ?ind ?sep a b) let arc astyle estyle ?stroke ?brush ?pen ?sep ?lab b1 b2 = let x1,y1 = let p = Box.ctr b1 in Point.xpart p, Point.ypart p and x2,y2 = let p = Box.north b2 in Point.xpart p, Point.ypart p in let boxdraw, linedraw = match astyle with | Directed -> box_arrow ?color:stroke ?brush ?pen ?sep, Arrow.simple ?color:stroke ?brush ?pen | Undirected -> box_line ?color:stroke ?brush ?pen ?sep, draw ?color:stroke ?brush ?pen in let drawlab b1 b2 = function | None -> nop | Some (pos, lab) -> let p = Box.cpath b1 b2 in label ~pos lab (Path.point 0.5 p) in match estyle with | Straight -> boxdraw ~style:jLine b1 b2 ++ drawlab b1 b2 lab | Curve -> let p1, p2 = Box.ctr b1, Box.ctr b2 in let corner = Point.pt (x2-/(x2-/x1) /./ 4.,(y1+/y2) /./ 2.) in let p = pathk ~style:jCurve (knotlist [noDir, p1, vec (Point.sub corner p1); noDir, corner, noDir; vec (Point.sub p2 corner), p2, noDir]) in let parrow = cut_after (Box.bpath b2) (cut_before (Box.bpath b1) p) in linedraw (strip ?sep parrow) | Square -> let corner = Point.pt (x2,y1) in let p = pathp ~style:jLine [Box.ctr b1; corner; Box.ctr b2] in let parrow = cut_after (Box.bpath b2) (cut_before (Box.bpath b1) p) in linedraw (strip ?sep parrow) | HalfSquare -> let m = (y1+/y2) /./ 2. in let corner1, corner2 = Point.pt (x1,m), Point.pt (x2,m) in let p = pathp ~style:jLine [Box.ctr b1; corner1; corner2; Box.ctr b2] in let parrow = cut_after (Box.bpath b2) (cut_before (Box.bpath b1) p) in linedraw (strip ?sep parrow) let is_leaf x = Array.length (Box.elts x ) = 1 let root x = (* if this access is invalid, the box has not been created using * [leaf], [node] or [bin] *) Box.nth 0 x let children x = if is_leaf x then [] else Box.elts_list (Box.nth 1 x) type t = (Box.t * node_info) tree let leaf b = Node ((b, dummy_info), []) let node ?(ls=bp 20.) ?(cs=bp 3.) ?(arrow_style=Directed) ?(edge_style=Straight) ?stroke ?brush ?pen ?sep b l = Node ((b, {ls = ls; cs = cs; arrow_style = arrow_style; edge_style = edge_style; stroke = stroke; pen = pen; sep = sep; lab = None}), l) let nodel ?(ls=bp 20.) ?(cs=bp 3.) ?(arrow_style=Directed) ?(edge_style=Straight) ?stroke ?brush ?pen ?sep b l = Node ((b, { ls = ls; cs = cs; arrow_style = arrow_style; edge_style = edge_style; stroke = stroke; pen = pen; sep = sep; lab = Some (List.map snd l)}), List.map fst l) let bin ?ls ?cs ?arrow_style ?edge_style ?stroke ?brush ?pen ?sep s x y = node ?ls ?cs ?arrow_style ?edge_style ?stroke ?brush ?pen ?sep s [x;y] let to_box t : Box.t = let rec draw x y (Node (((b, ni), dx, dy), tl)) = let {stroke=stroke; pen=pen; sep=sep} = ni in let x' = addn x dx in let y' = subn y (divf (Box.height b) 2.)in let y2 = subn y (maxn dy ni.ls) in let b = Box.group [Box.center (Point.pt (x', y')) b; Box.group (List.map (draw x' y2) tl)] in let draw_arcs tree = match ni.lab with | None -> Command.iterl (fun child -> arc ~brush:(Types.mkBrush stroke pen None) ?sep ni.arrow_style ni.edge_style (root tree) (root child)) (children tree) | Some lab -> Command.iterl (fun (child, lab) -> arc ~brush:(Types.mkBrush stroke pen None) ?sep ~lab ni.arrow_style ni.edge_style (root tree) (root child)) (List.combine (children tree) lab) in Box.set_post_draw draw_arcs b in draw zero zero (design t) let draw ?debug t = Box.draw ?debug (to_box t) module Simple = struct type t = Box.t let leaf s = Box.group [s] let node ?(ls=Num.bp 12.) ?(cs=Num.bp 5.) ?(arrow_style=Directed) ?(edge_style=Straight) ?stroke ?brush ?pen ?sep ?(valign=`Center) ?(halign=`North) s l = let l = Box.hbox ~padding:cs ~pos:halign l in let tree = Box.vbox ~padding:ls ~pos:valign [s;l] in Box.set_post_draw (fun tree -> (Command.iterl (fun child -> arc ?stroke ?brush ?pen ?sep arrow_style edge_style (root tree) (root child)) (children tree))) tree let bin ?ls ?cs ?arrow_style ?edge_style ?stroke ?brush ?pen ?sep s x y = node ?ls ?cs ?arrow_style ?edge_style ?stroke ?brush ?pen ?sep s [x;y] let to_box b = b let draw = Box.draw end mlpost-0.8.1/META.in0000644000443600002640000000056311365367177013303 0ustar kanigdemonsdescription = "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.1/handbookgraphs.ml0000644000443600002640000002315511365367177015553 0ustar kanigdemons(**************************************************************************) (* *) (* 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 Command open Picture module H = Helpers open Num open Num.Infix open Point open Path module MP = MetaPath let draw1 = 1, seq [ draw (path ~style:jLine [20.,20.; 0.,0.; 0.,30.; 30.,0.; 0.,0.])] let z0 = 0.,0. let z1 = 60.,40. let z2 = 40.,90. let z3 = 10.,70. let z4 = 30.,50. let l1 = z0::z1::z2::z3::z4::[] let labels1 = seq [H.dotlabels ~pos:`North ["0";"2";"4"] (map_bp [z0;z2;z4]); dotlabel ~pos:`West (tex "3") (bpp z3); dotlabel ~pos:`Southeast (tex "1") (bpp z1) ] let draw3 = 3, seq [ draw (path ~style:jCurve l1); labels1 ] let draw4a, draw4b = let labels = seq [ H.dotlabels ~pos:`North ["2";"4"] (map_bp [z2;z4]); H.dotlabels ~pos:`West ["0";"3"] (map_bp [z0;z3]); dotlabel ~pos:`Southeast (tex "1") (bpp z1) ] in (104, seq [ draw (path ~cycle:jCurve l1); labels]) , (204, seq [ draw (Path.append ~style:jLine (path [z0;z1;z2;z3]) (path ~style:jLine [z4;z0]) ); labels ]) (* no easy alternative way to draw this one, and that's fine *) let l1dirs = List.map (knot) l1 let lcontrols = [(26.8, -1.8), (51.4,14.6); (67.1, 61.), (59.8,84.6); (25.4, 94.), (10.5,84.5); (9.6, 58.8), (18.8,49.6)] let lcontrolsbp = List.map (fun (a,b) -> jControls (bpp a) (bpp b)) lcontrols let draw5 = 5, seq [ draw (jointpath l1 lcontrolsbp) ; (let hull = List.fold_left2 (fun acc (c1, c2) f -> f::c2::c1::acc) [0.,0.] lcontrols (List.tl l1) in (* As long as we dont have the dashed lines : gray *) draw ~dashed:(Dash.scaled 0.5 Dash.evenly) (path ~style:jLine (List.rev hull))) ; labels1 ] let draw6 = 6, seq [ draw (pathk [ knot z0; knot ~r:(vec up) z1; knot ~r:(vec left) z2; knot z3; knot z4] ); labels1 ] let lex = MP.knot ~r:(vec (dir 45.)) (0.,0.) let rex a = MP.knot ~l:(vec (dir (10.*.a))) ~scale:cm (6., 0.) let draw7 = 7, seq [Command.iter 0 9 (fun a -> let p = MP.concat (MP.start lex) ~style:jCurve (rex (float_of_int (-a))) in draw (MP.to_path p) ) ] let draw8 = 8, seq [Command.iter 0 7 (fun a -> let p = MP.concat (MP.start lex) ~style:jCurve (rex (float_of_int a)) in draw (MP.to_path p) ) ] let z0 = (-1., 0.) let z1 = (0., 0.2) let z2 = ( 1., 0.) let labels9 = H.dotlabels ~pos:`South ["0";"1";"2"] (map_in [z0;z1;z2]) let z0 = knot ~r:(vec up) ~scale:inch z0 let z1 = knot ~r:(vec right) ~scale:inch z1 let z2 = knot ~r:(vec down) ~scale:inch z2 let draw9a = 109, seq [draw (pathk [z0;z1;z2]); labels9 ] let draw9b = 209, seq [draw (pathk ~style:jCurveNoInflex [z0;z1;z2]); labels9 ] let u l = 1.5 /. 10. *. l let z0 = (u (-5.)), 0. let z1 = (u (-3.)),u 2. let z2 = (u 3.),u 2. let z3 = (u 5.),u 0. let l1 = [z0;z1;z2;z3] let labels10 = H.dotlabels ~pos:`South ["0";"1";"2";"3"] (map_in l1) let draw10a = 110, seq [draw (path ~scale:inch l1); labels10 ] let draw10b = 210, seq [ draw (jointpath ~scale:inch l1 [jCurve; jTension 1.3 1.3; jCurve] ); labels10 ] let draw10c = 310, seq [ draw (jointpath ~scale:inch l1 [jCurve; jTension 1.5 1.0; jCurve] ); labels10 ] let u l = 1.4 /. 10. *. l let z0 = u (2.), u (-5.) let z1 = 0., 0. let z2 = u 2., u 5. let cl = [0.; 1.; 2.; infinity] let u l = 1.4 /. 10. *. l let z0 = u (2.), u (-5.) let z1 = 0., 0. let z2 = u 2., u 5. let cl = [0.; 1.; 2.; infinity] let pat c = [ knot ~r:(curl c) ~scale:inch z0 ; knot ~scale:inch z1; knot ~l:(curl c) ~scale:inch z2 ] let draw11 = let numbers = [111; 211; 311; 411] in let labels11 = H.dotlabels ~pos:`East ["0";"1";"2"] (map_in [z0;z1;z2]) in List.map2 (fun c n -> n, seq [draw (pathk (pat c) ); labels11 ] ) cl numbers let draw17 = let a, b = Num.inch (0.7), Num.inch (0.5) in let z0 = p (0.,0.) in let z1 = pt (a, zero) and z3 = pt (neg a, zero) in let z2 = pt (zero, b) and z4 = pt (zero, neg b) in 17, seq [draw (pathp ~cycle:jCurve [z1;z2;z3;z4]); draw (pathp ~style:jLine [z1; z0; z2]); label ~pos:`North (tex "a") (segment 0.5 z0 z1); label ~pos:`West (tex "b") (segment 0.5 z0 z2); dotlabel ~pos:`South (tex "(0,0)") z0 ] let draw18 = let u = Num.cm in let pen = Pen.scale one Pen.circle in let rec pg = function | 0 -> MP.start (MP.knot ~r:(vec up) ~scale:u (0.,0.)) | n -> let f = (float_of_int n /. 2.) in MP.concat ~style:jCurve (pg (n-1)) (MP.knot ~scale:u (f, sqrt f)) in 18, seq [draw (pathn ~style:jLine [(zero,u 2.); (zero,zero); (u 4.,zero)]); draw ~pen (MP.to_path (pg 8)); label ~pos:`Southeast (tex "$ \\sqrt x$") (pt (u 3., u (sqrt 3.))); label ~pos:`South (tex "$x$") (pt (u 2., zero)); label ~pos:`Southwest (tex "$y$") (pt (zero, u 1.))] let draw19 = let ux, uy = Num.inch 0.01, Num.inch 0.6 in let dux, duy = 120. *./ ux, 4. *./ uy in let pen = Pen.scale one Pen.circle in let axey = Picture.transform [Transform.rotated 90.] (tex "axe $y$") in let rec pg = function | 0 -> start (knotn ~r:(vec right) (zero,uy)) | n -> let k = (float_of_int n)*.15. in concat ~style:jCurve (pg (n-1)) (knotn (k *./ ux, 2. /. (1. +. (cos (Num.deg2rad k))) *./ uy)) in 19, [draw (pathn ~style:jLine [(zero,duy); (zero,zero); (dux,zero)]); draw ~pen (pg 8); label ~pos:`South (tex "axe $x$") (pt (60.*./ux, zero)); label ~pos:`West axey (pt (zero, 2.*./uy)); label ~pos:`West (tex "$\\displaystyle y={2\\over1+\\cos x}$") (pt (dux, duy))] (** Cette version de draw21 est assez cool mais ne marche pas car la largeur du trait est scalée avec la figure... *) (* let draw21 = *) (* let path = transform t halfcircle in *) (* let r = Vec (p (Num.bp (-.1.), Num.bp (-.2.))) in *) (* let fillp = *) (* cycle (Vec up) JCurve (concat path JCurve (C.p ~r ~scale:C.CM (0.,0.))) in *) (* 21, [fill fillp; draw (transform t fullcircle)] *) let draw21 = let mp d pt = knot ~r:(vec d) ~scale:cm pt in let kl = [mp down (-1.,0.); mp right (0.,-1.); mp up (1.,0.)] in let path = pathk kl in let r = p (-.1., -.2.) in let fillp = cycle ~dir:(vec up) (concat path (mp r (0.,0.))) in let fullp = cycle (concat path (mp left (0.,1.))) in 21, seq [fill fillp; draw fullp] let draw22 = let a = Path.scale (cm 2.) fullcircle in let aa = Path.scale (cm 2.) halfcircle in let b = Path.shift (pt (zero, Num.cm 1.)) a in let pa = label (tex "$A$") (pt (zero, Num.cm (-0.5))) in let pb= label (tex "$B$") (pt (zero, Num.cm 1.5)) in let ab = build_cycle [aa; b] in let pic = (seq [fill ~color:(Color.gray 0.7) a; fill ~color:(Color.gray 0.7) b; fill ~color:(Color.gray 0.4) ab; fill ~color:Color.white (bbox pa); pa; fill ~color:Color.white (bbox pb); pb; label ~pos:`West (tex "$U$") (p ~scale:Num.cm (-1.,0.5)); ]) in 22, seq [pic; draw (bbox pic)] let draw40 = let k1 = knot ~r:(curl 0.) ~scale:Num.pt (0.,0.) in let k2 = knot ~scale:Num.pt (5., -3.) in let k3 = knot ~scale:Num.pt ~l:(curl 0.) (10.,0.) in let p1 = pathk [k1;k2;k3] in let p2 = append p1 (Path.shift (p ~scale:Num.pt (10.,0.)) (Path.yscale (neg one) p1)) in let p2 = Misc.fold_from_to (fun acc i -> append acc (Path.shift (p ~scale:Num.pt (float_of_int i *. 20.,0.)) p2)) p2 1 3 in let cmd = Command.iter 0 8 (fun i -> draw (Path.shift (p ~scale:Num.pt (0., float_of_int i *. 10.)) p2)) in let pth = Path.scale (Num.pt 72.) (Path.shift (p (0.5, 0.5)) fullcircle) in let pic' = Picture.clip cmd pth in 40, seq [pic'; draw pth] 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*) [ draw1; draw3; draw4a; draw4b;draw5; draw6; draw7; draw8; draw9a; draw9b; draw10a; draw10b; draw10c] @ draw11 @ [draw17; draw18; draw21; draw22; draw40] let mpostfile = "testmanualMP" let cairostfile = "testmanual_cairo" let texfile = "testmanual.tex" let _ = Sys.chdir "test"; if Cairost.supported then begin Metapost.generate mpostfile ~pdf:true figs; Cairost.generate_pdfs cairostfile figs; Generate.generate_tex_cairo texfile "manual/manual" "testmanualMP" "testmanual_cairo" figs; end else begin Metapost.generate mpostfile ~pdf:true figs; Generate.generate_tex ~pdf:true texfile "manual/manual" "testmanualMP" figs; end mlpost-0.8.1/mlpost.mli0000644000443600002640000025563011365367177014255 0ustar kanigdemons(**************************************************************************) (* *) (* 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 *) module Signature : sig type point type num module type Boxlike = sig type t val width : t -> num val height : t -> num val set_pos : point -> t -> t end end (** {2 Interfaces to basic Metapost datatypes} *) (** Abstract numeric values *) module Num : sig (** Numerics are a symbolic representation of numeric values. In many cases, but not always, an object of type {!Num.t} is intended to be a length in some unit. In addition, values of type {!Num.t} may actually be unknown to Mlpost. This is why there is no function that gives back a [float]. *) type t = Signature.num (** The Mlpost numeric type is an abstract datatype *) (** {2 Conversion functions} *) val of_float : float -> t (** Convert a float into a {!Num.t} *) val bp : float -> t (** The base unit in Mlpost is bp. *) val pt : float -> t (** pt are PostScript points. This is the same unit as the pt unit in TeX *) val cm : float -> t val mm : float -> t val inch : float -> t (** The following are units dependent of the font used *) val em : float -> t (** the width of an "m" *) val ex : float -> t (** the height of an "x" *) (** {2 Useful operations on Nums} *) val addn : t -> t -> t val subn : t -> t -> t val multn : t -> t -> t val multf : float -> t -> t val divf : t -> float -> t val neg : t -> t val divn : t -> t -> t val maxn : t -> t -> t val minn : t -> t -> t val gmean : t -> t -> t (** the geometric mean of two nums : sqrt(a * a + b * b) *) val if_null : t -> t -> t -> t (** if_null n n1 n2 is equal to n1 if n is null, n2 othewise *) (** {3 Infix operators} *) module Infix : sig (** Infix symbols for convenience *) val (+/) : t -> t -> t (** alias for {!Num.addn} *) val (-/) : t -> t -> t (** alias for {!Num.subn} *) val ( */) : t -> t -> t (** alias for {!Num.multn} *) val (//) : t -> t -> t (** alias for {!Num.divn} *) val ( *./): float -> t -> t (** alias for {!Num.multf} *) val (/./): t -> float -> t (** alias for {!Num.divf} *) end (** {2 Useful constants and functions} *) val zero : t val one : t val two : t (** Shortcuts for [bp 0.], [bp 1.] and [bp 2.]. *) val pi : float (** 3 .14159 *) val deg2rad : float -> float (** Converts degrees into radians *) type scale = float -> t module Scale : sig val bp : float -> scale val pt : float -> scale val cm : float -> scale val mm : float -> scale val inch : float -> scale end end (** Definitions of many colors *) module Color : sig (** Colors *) type t (** the abstract type of colors *) val default : t (** the default color is black *) val rgb : float -> float -> float -> t (** [rgb r g b] constructs the color that corresponds to the color code RGB(r,g,b) *) val rgb8 : int -> int -> int -> t (** similar to [rgb], but takes integers between 0 and 255 as argument *) val cmyk : float -> float -> float -> float -> t (** [cmyk c m y k] constructs the color that corresponds to the color code CMYK(c,m,y,k) *) val rgba : float -> float -> float -> float -> t (** similar to [rgb], but takes the factor of transparency *) val rgb8a : int -> int -> int -> int -> t (** similar to [rgb8], but takes the factor of transparency *) val cmyka : float -> float -> float -> float -> float -> t (** similar to [cmyk], but takes the factor of transparency *) val is_opaque : t -> bool (** test if the color is opaque *) val opaque : t -> t (** make a color opaque *) val transparent : float -> t -> t (** [transparent f c] multiplies by f the factor of transparency of c *) val hsv : float -> float -> float -> t (** hsv h s v convert an hsv color to an rgb. 0 <= h < 360, 0 <= s,v <= 1*) (** {3 color generator} *) val color_gen : float -> float -> (unit -> t) (* color_gen s v creates a generator of colors which return a different color (with saturation s and value v) each time it is called. The goal is to have colors with a good contrast between them. For given s and v the resutl is deterministically *) (** {2 Predefined Colors} *) (** {3 base colors} *) val white : t val black : t val red : t val blue : t val green : t val cyan : t val yellow : t val magenta : t (** {3 lighter colors} *) val lightred : t val lightblue : t val lightgreen : t val lightcyan : t val lightyellow : t val lightmagenta : t (** {3 grays} *) val gray : float -> t val lightgray : t val mediumgray : t val darkgray : t (** {3 additional colors} *) val orange : t val purple : t (** {3 X11-named Colors} *) val color : string -> t (** [color n] returns the RGB color associated to name [n] (as defined in /etc/X11/rgb.txt). Raises [Not_found] if [n] does not correspond to a color. See {{:http://en.wikipedia.org/wiki/X11_color_names} this list} for an overview.*) end (** Points in the plane *) module rec Point : sig (** The abstract type for points *) type t = Signature.point (** Construct a point from two numeric values *) val pt : Num.t * Num.t -> t (** The following functions create points of length 1. They are especially useful to specify directions with [Path.Vec] *) (** [dir f] is the point at angle [f] on the unit circle. [f] shall be given in degrees *) val dir : float -> t (** The unitary vectors pointing up, down, left and right *) val up : t val down : t val left : t val right : t val origin : t val length : t -> Num.t (** [length p] is the length of vector from the origin to [p] *) val xpart : t -> Num.t (** [xpart p] is the x coordinate of point [p] *) val ypart : t -> Num.t (** [ypart p] is the y coordinate of point [p] *) (** {2 Operations on points} *) val transform : Transform.t -> t -> t (** Apply a transformation to a point *) val segment : float -> t -> t -> t (** [segment f p1 p2] is the point [(1-f)p1 + fp2]. Stated otherwise, if [p1] is at [0.] and [p2] is at [1.], return the point that lies at [f] *) val add : t -> t -> t val shift : t -> t -> t (** Sum two points *) val sub : t -> t -> t (** Substract two points *) val mult : Num.t -> t -> t val scale : Num.t -> t -> t (** Multiply a point by a scalar *) val rotate : float -> t -> t (** Rotate a point by an angle in degrees *) (** [rotate_around p1 f p2] rotates [p2] around [p1] by an angle [f] in degrees *) val rotate_around : t -> float -> t -> t (** Scales the X coordinate of a point by a scalar *) val xscale : Num.t -> t -> t (** Scales the Y coordinate of a point by a scalar *) val yscale : Num.t -> t -> t (** Normalize the vector represented by the point. The origin becomes the origin *) val normalize : t -> t (** {2 Convenient constructors} *) (** The following functions build a point at a given scale (see {!Num.t} for scales) *) val bpp : float * float -> t val inp : float * float -> t val cmp : float * float -> t val mmp : float * float -> t val ptp : float * float -> t (** Same as the previous functions but build list of points *) val map_bp : (float * float) list -> t list val map_in: (float * float) list -> t list val map_cm: (float * float) list -> t list val map_mm: (float * float) list -> t list val map_pt: (float * float) list -> t list (** Builds a point from a pair of floats @param scale a scaling function to be applied to each float; see {!Num.t} for scaling functions for usual units *) val p : ?scale:(float -> Num.t) -> float * float -> t (** Same as [p], but builds a list of points *) val ptlist : ?scale:(float -> Num.t) -> (float * float) list -> t list val draw : ?brush:Brush.t -> ?color:Color.t -> ?pen:Pen.t -> t -> Command.t (** Draw a point @param color the color of the point; default is black @param pen the pen used to draw the pen; default is [Brush.Pen.default]*) end (** MetaPaths: gradually build a path with constraints, get a real path at thxe end. *) and MetaPath : sig (** MetaPaths are the objects used to describe lines, curves, and more generally almost everything that is drawn with Mlpost. A path ([Path.t]) is defined by points and control points. A metapath is defined by points (knots) and constraints on the links between the points. A metapath is an easy way to define a path gradually with only a few points, and apply heuristics afterwards to transform it into a real path (using [of_metapath]). *) (** A [direction] is used to put constraints on metapaths: {ul {- [vec p] defines a direction by a point (interpreted as a vector)} {- [curl f] changes the curling factor of the extremity of a metapath; higher curling factor means flatter curves} {- [noDir] means no particular direction} } *) type direction = Path.direction val vec : Point.t -> direction val curl : float -> direction val noDir : direction (** A [knot] is the basic element of a metapath, and is simply a point with an incoming and outgoing direction constraint *) type knot = Path.knot (** Build a knot from a point; the optional arguments are the incoming directions *) val knotp : ?l:direction -> ?r:direction -> Point.t -> knot val knotlist : (direction * Point.t * direction) list -> knot list (** A joint is the connection between two knots in a metapath. It is either {ul {- [jLine] for a straight line} {- [jCurve] for a spline curve} {- [jCurveNoInflex] to avoid inflexion points} {- [jTension f1 f2] to specify "tension" on the joint; [jCurve] uses a default tension of 1. Higher tension means less "wild" curves} {- [jControls p1 p2] to explicitely specify control points}} *) type joint = Path.joint val jLine : joint val jCurve : joint val jCurveNoInflex : joint val jTension : float -> float -> joint val jControls : Point.t -> Point.t -> joint (** The abstract type of metapaths *) type t type path = Path.t (** In all the functions below : - noDir is the default direction - jCurve is the default joint *) (** {2 Labelled metapath constructors} *) (** Build a knot from a pair of floats @param l an incoming direction @param r an outgoing direction @param scale a scaling factor applied to the floats *) val knot : ?l:direction -> ?r:direction -> ?scale:(float -> Num.t) -> float * float -> knot (** Build a knot from a Num.t pair; the optional arguments are as in {!knot} *) val knotn : ?l:direction -> ?r:direction -> Num.t * Num.t -> knot (** Build a metapath from a list of pairs of floats @param style the joint style used for all joints in the metapath @param cycle if given, the metapath is closed using the given style @param scale permits to scale the whole metapath *) val path : ?style:joint -> ?scale:(float -> Num.t) -> (float * float) list -> t (** Same as [metapath], but uses a [Num.t] list *) val pathn : ?style:joint -> (Num.t * Num.t) list -> t (** Same as [metapath], but uses a knot list *) val pathk : ?style:joint -> knot list -> t (** Same as [metapath] but uses a point list *) val pathp : ?style:joint -> Point.t list -> t (** Build a metapath from [n] knots and [n-1] joints *) val jointpathk : knot list -> joint list -> t (** Build a metapath from [n] points and [n-1] joints, with default directions *) val jointpathp : Point.t list -> joint list -> t val jointpathn : (Num.t * Num.t) list -> joint list -> t (** Build a metapath from [n] float_pairs and [n-1] joints, with default directions *) val jointpath : ?scale:(float -> Num.t) -> (float * float) list -> joint list -> t (** Close a metapath using direction [dir] and style [style] *) val cycle : ?dir:direction -> ?style:joint -> t -> path (** {2 Primitive metapath constructors} *) (** Add a knot at the end of a metapath *) val concat : ?style:joint -> t -> knot -> t (** Create a simple metapath with one knot *) val start : knot -> t (** Append a metapath to another using joint [style] *) val append : ?style:joint -> t -> t -> t (** {2 Predefined values} *) (** The default joint style ([JCurve]) *) val defaultjoint : joint (** {2 Conversions} *) (** Compute the control point of the path for a good looking result according to the constraint on the direction, tension, curve *) val to_path : t -> path (** Obtain a metapath from a path with exactly the same control point. p = of_metapath (of_path p) is true but not the opposite.*) val of_path : path -> t end (** Fixed Paths *) and Path : sig (** Paths are the objects used to describe lines, curves, and more generally almost everything that is drawn with Mlpost *) (** A [direction] is used to put constraints on paths: {ul {- [vec p] defines a direction by a point (interpreted as a vector)} {- [curl f] changes the curling factor of the extremity of a path; higher curling factor means flatter curves} {- [noDir] means no particular direction} } *) type direction val vec : Point.t -> direction val curl : float -> direction val noDir : direction (** A [knot] is the basic element of a path, and is simply a point with an incoming and outgoing direction constraint *) type knot (** Build a knot from a point; the optional arguments are the incoming directions *) val knotp : ?l:direction -> ?r:direction -> Point.t -> knot val knotlist : (direction * Point.t * direction) list -> knot list (** A joint is the connection between two knots in a path. It is either {ul {- [jLine] for a straight line} {- [jCurve] for a spline curve} {- [jCurveNoInflex] to avoid inflexion points} {- [jTension f1 f2] to specify "tension" on the joint; [jCurve] uses a default tension of 1. Higher tension means less "wild" curves} {- [jControls p1 p2] to explicitely specify control points}} *) type joint val jLine : joint val jCurve : joint val jCurveNoInflex : joint val jTension : float -> float -> joint val jControls : Point.t -> Point.t -> joint (** The abstract type of paths *) type t (** In all the functions below : - noDir is the default direction - jCurve is the default joint *) (** {2 Labelled path constructors} *) (** Build a knot from a pair of floats @param l an incoming direction @param r an outgoing direction @param scale a scaling factor applied to the floats *) val knot : ?l:direction -> ?r:direction -> ?scale:(float -> Num.t) -> float * float -> knot (** Build a knot from a Num.t pair; the optional arguments are as in {!knot} *) val knotn : ?l:direction -> ?r:direction -> Num.t * Num.t -> knot (** Build a path from a list of pairs of floats @param style the joint style used for all joints in the path @param cycle if given, the path is closed using the given style @param scale permits to scale the whole path *) val path : ?style:joint -> ?cycle:joint -> ?scale:(float -> Num.t) -> (float * float) list -> t (** Same as [path], but uses a [Num.t] list *) val pathn : ?style:joint -> ?cycle:joint -> (Num.t * Num.t) list -> t (** Same as [path], but uses a knot list *) val pathk : ?style:joint -> ?cycle:joint -> knot list -> t (** Same as [path] but uses a point list *) val pathp : ?style:joint -> ?cycle:joint -> Point.t list -> t (** Build a path from [n] knots and [n-1] joints *) val jointpathk : knot list -> joint list -> t (** Build a path from [n] points and [n-1] joints, with default directions *) val jointpathp : Point.t list -> joint list -> t val jointpathn : (Num.t * Num.t) list -> joint list -> t (** Build a path from [n] float_pairs and [n-1] joints, with default directions *) val jointpath : ?scale:(float -> Num.t) -> (float * float) list -> joint list -> t (** Close a path using direction [dir] and style [style] *) val cycle : ?dir:direction -> ?style:joint -> t -> t (** {2 Primitive path constructors} *) (** Add a knot at the end of a path *) val concat : ?style:joint -> t -> knot -> t (** Create a simple path with one knot *) val start : knot -> t (** Append a path to another using joint [style] *) val append : ?style:joint -> t -> t -> t (** {2 More complex constructions on paths} *) (** Number of nodes in a path, minus one. *) val length : t -> Num.t (** [point f p] returns a certain point on the path [p]; [f] is given "in control points": [0.] means the first control point, [1.] the second and so on; intermediate values are accepted. *) val point : float -> t -> Point.t (** Same as [point] but for a [Num.t]. *) val pointn : Num.t -> t -> Point.t (** [direction f p] returns the direction of the tangent at [point f p]. *) val direction : float -> t -> Point.t (** Same as [direction] but for a [Num.t]. *) val directionn : Num.t -> t -> Point.t (** [subpath start end path] selects the subpath of [path] that lies between [start] and [end]. [start] and [end] are given in control points, as in {!point}. *) val subpath : float -> float -> t -> t (** Same as [subpathn] but using [Num.t]. *) val subpathn : Num.t -> Num.t -> t -> t (** Apply a transformation to a path *) val transform : Transform.t -> t -> t val scale : Num.t -> t -> t val rotate : float -> t -> t val shift : Point.t -> t -> t val yscale : Num.t -> t -> t val xscale : Num.t -> t -> t (** Shortcuts for transformations of Paths *) (** [cut_after p1 p2] cuts [p2] after the intersection with [p1]. To memorize the order of the arguments, you can read: "cut after [p1]" *) val cut_after : t -> t -> t (** Same as {!cut_after}, but cuts before *) val cut_before: t -> t -> t (** [strip n p] removes two segments of length [n] at each end of path [p] *) val strip : Num.t -> t -> t (** Build a cycle from a set of intersecting paths *) val build_cycle : t list -> t (** {2 Predefined values} *) (** The default joint style ([JCurve]) *) val defaultjoint : joint (** A full circle of radius 1 and centered on the origin *) val fullcircle : t (** The upper half of [fullcircle] *) val halfcircle : t (** The right half of [halfcircle] *) val quartercircle: t (** A full square of size 1 and centered on the origin *) val unitsquare: t (** {2 Conversions} *) type metapath = MetaPath.t (** Compute the control point of the path for a good looking result according to the constraint on the direction, tension, curve *) val of_metapath : metapath -> t (** Obtain a metapath from a path with exactly the same control point. p = of_metapath (of_path p) is true but not the opposite.*) val to_metapath : t -> metapath (** {2 Smart path } *) type orientation = | Up | Down | Left | Right | Upn of Num.t | Downn of Num.t | Leftn of Num.t | Rightn of Num.t val smart_path : ?style:joint -> orientation list -> Point.t -> Point.t -> t val draw : ?brush:Brush.t -> ?color:Color.t -> ?pen:Pen.t -> ?dashed:Dash.t -> t -> Command.t (** Draw a path @param brush the brush used to draw the path; the next argument redefined this one @param color the color of the path; default is black @param pen the pen used to draw the path; default is [Brush.Pen.default] @param dashed if given, the path is drawn using that dash_style. *) val fill : ?color:Color.t -> t -> Command.t (** Fill a contour given by a closed path @param color the color used to fill the area; default is black *) end (**/**) (** Pens: change the way lines are drawn in Mlpost *) and Pen : sig (** Pens are used to change the the way lines are drawn in Mlpost *) type t (** The abstract type of pens *) val transform : Transform.t -> t -> t (** Apply a transformation to pens *) val default : t (** The default pen; it corresponds to [Pen.scale (Num.bp 0.5) Pen.circle] *) val circle : t (** A circular pen of diameter 1 bp *) val square : t (** A pen in form of a square, of length 1 bp *) val from_path : Path.t -> t (** Construct a pen from a closed path *) val scale : Num.t -> t -> t val rotate : float -> t -> t val shift : Point.t -> t -> t val yscale : Num.t -> t -> t val xscale : Num.t -> t -> t (** Shortcuts for transformations of pens *) end (** Dash patterns *) and Dash : sig (** This module permits to define dash patterns, that are used to draw lines in different styles *) type t (** The abstract type of dash patterns *) val evenly : t (** The pattern composed of evenly spaced dashes *) val withdots : t (** The pattern composed of evenly spaced dots *) val scaled : float -> t -> t (** Scale a dash pattern *) val shifted : Point.t -> t -> t (** Shift a dash pattern *) type on_off val on : Num.t -> on_off val off : Num.t -> on_off val pattern : on_off list -> t (** This function, together with the type [on_off] permits to construct custom dash patterns, by giving a list of [on] / [off] constructors, with corresponding lengths *) end (**/**) (** Brushes : change the way lines are drawn in Mlpost *) and Brush : sig (** Pens: change the way lines look like in Mlpost *) module Pen : sig (** Pens are used to change the the way lines are drawn in Mlpost *) type t (**/**) = Pen.t (**/**) (** The abstract type of pens *) val transform : Transform.t -> t -> t (** Apply a transformation to pens *) val default : t (** The default pen; it corresponds to [Pen.scale (Num.bp 0.5) Pen.circle] *) val circle : t (** A circular pen of diameter 1 bp *) val square : t (** A pen in form of a square, of length 1 bp *) val from_path : Path.t -> t (** Construct a pen from a closed path *) val scale : Num.t -> t -> t val rotate : float -> t -> t val shift : Point.t -> t -> t val yscale : Num.t -> t -> t val xscale : Num.t -> t -> t (** Shortcuts for transformations of pens *) end (** Dash patterns *) module Dash : sig (** This module permits to define dash patterns, that are used to draw lines in different styles *) type t (**/**) = Dash.t (**/**) (** The abstract type of dash patterns *) val evenly : t (** The pattern composed of evenly spaced dashes *) val withdots : t (** The pattern composed of evenly spaced dots *) val scaled : Num.t -> t -> t (** Scale a dash pattern *) val shifted : Point.t -> t -> t (** Shift a dash pattern *) type on_off val on : Num.t -> on_off val off : Num.t -> on_off val pattern : on_off list -> t (** This function, together with the type [on_off] permits to construct custom dash patterns, by giving a list of [on] / [off] constructors, with corresponding lengths *) end type t val t : ?color:Color.t -> ?pen:Pen.t -> ?dash:Dash.t -> ?scale:Num.t -> ?brush:t -> (* use the value of brush for the default value *) unit -> t val pen : t -> Pen.t option val dash : t -> Dash.t option val color : t -> Color.t option (** {2 Brushes with Predefined Colors} *) type brush_colored = ?pen:Pen.t -> ?dash:Dash.t -> ?scale:Num.t -> ?brush:t -> unit -> t (** {3 base colors} *) val white : brush_colored val black : brush_colored val red : brush_colored val blue : brush_colored val green : brush_colored val cyan : brush_colored val yellow : brush_colored val magenta : brush_colored (** {3 lighter colors} *) val lightred : brush_colored val lightblue : brush_colored val lightgreen : brush_colored val lightcyan : brush_colored val lightyellow : brush_colored val lightmagenta : brush_colored (** {3 grays} *) val gray : float -> brush_colored val lightgray : brush_colored val mediumgray : brush_colored val darkgray : brush_colored (** {3 additional colors} *) val orange : brush_colored val purple : brush_colored end (** Apply linear transformations to objects in Mlpost *) and Transform : sig (** Transformations are an important way to modify objects in Mlpost. Objects can be scaled, shifted, rotated, etc, and any combination of these transformations is possible. Currently, transformations can be applied to Pictures, Pens and Paths. *) type t' (** The abstract type of a single transformation *) val scaled : Num.t -> t' (** Scale an object by a constant factor. @param scale a scaling function to be applied to each float; see {!Num.t} for scaling functions for usual units. This makes only sense when the object to be transformed is given in "bp" units *) val rotated : float -> t' (** Rotate an object by an angle given in degrees *) val shifted : Point.t -> t' (** Shift an object with respect to a point *) val slanted : Num.t -> t' (** Slant an object: the point [(x,y)] becomes [(x+ay,y)], with slanting factor [a] *) val xscaled : Num.t -> t' (** Scale an object by a constant factor, but only in the [x] direction *) val yscaled : Num.t -> t' (** Scale an object by a constant factor, but only in the [y] direction *) val zscaled : Point.t -> t' (** Zscaled multiplies points of the object by the given point, using "complex" multiplication: [(x,y) * (a,b) = (ax - by, bx + ay)]; its effect is to rotate and scale so as to map [(1,0)] into [(a,b)] *) val reflect : Point.t -> Point.t -> t' (** Reflect an object with respect to the line that goes through the two given points *) val rotate_around : Point.t -> float -> t' (** Rotate an object by an angle given in degrees, around a given point *) type matrix = { xx : Num.t; yx : Num.t; xy : Num.t; yy : Num.t; x0 : Num.t; y0 : Num.t} val explicit : matrix -> t' type t = t' list (** A transformation is a list of single transformations *) val id : t (** The identity transformation *) end (** Functions to manipulate commands as if they were pictures *) and Picture : sig (** Pictures are a powerful way to reuse and modify parts of a figure *) type t = Command.t (** The abstract type of pictures *) val make : Command.t -> t (** Make a picture from a drawing command *) val tex : string -> t (** Take a string in Latex format and transform it into a picture *) val transform : Transform.t -> t -> t (** Apply a transformation to a picture *) val bbox : t -> Path.t (** Get the bounding box of a picture (with default padding, as in MetaPost) *) val corner_bbox : ?dx:Num.t -> ?dy:Num.t -> t -> Path.t (** Get the bounding box of a picture, according to its corners and supplied padding [dx] and [dy]. *) val center : Point.t -> t -> t (** Place a picture centered at some point *) val place_up_left : Point.t -> t -> t (** Place a picture with its upper left corner at some point *) val place_up_right : Point.t -> t -> t (** Place a picture with its upper right corner at some point *) val place_bot_left : Point.t -> t -> t (** Place a picture with its bottom left corner at some point *) val place_bot_right : Point.t -> t -> t (** Place a picture with its bottom right corner at some point *) val beside : t -> t -> t (** [beside p1 p2] returns a picture in which [p2] is placed right to [p1] *) val below : t -> t -> t (** [below p1 p2] returns a picture in which [p2] is placed below [p1] *) (** {2 Special points of the bounding box of a picture} *) val ctr : t -> Point.t (** @img ctr.png *) val north : t -> Point.t (** @img north.png *) val south : t -> Point.t (** @img south.png *) val west : t -> Point.t (** @img west.png *) val east : t -> Point.t (** @img east.png *) val north_west : t -> Point.t (** @img north_west.png *) val south_west : t -> Point.t (** @img south_west.png *) val north_east : t -> Point.t (** @img north_east.png *) val south_east : t -> Point.t (** @img south_east.png *) val corner : Command.position -> t -> Point.t (** {2 Special points of the bounding box of a picture (Deprecated)} *) (** These have been superseded by the preceding functions *) val ulcorner : t -> Point.t val llcorner : t -> Point.t val urcorner : t -> Point.t val lrcorner : t -> Point.t val clip : t -> Path.t -> t (** [clip pic path] limits [pic] to the cyclic path [path]; all elements outside of [path] are cut off. *) (** {2 Dimensions} *) val width : t -> Num.t val height : t -> Num.t (** Predefined Transformations *) val scale : Num.t -> t -> t val rotate : float -> t -> t val shift : Point.t -> t -> t val yscale : Num.t -> t -> t val xscale : Num.t -> t -> t val spin : float -> t -> t type escaped = [`Backslash|`Underscore] val escape_latex : escaped list -> string -> string val escape_all : string -> string val set_pos : Point.t -> t -> t (** alias of center *) end (** Basic drawing commands *) and Command : sig (** Set the verbosity of all mlpost *) val set_verbosity : bool -> unit (** General Commands to build figures *) type t (** The abstract commands type *) (* val logo : figure (** The Mlpost logo. *) *) (** {2 Drawing Commands} *) val draw : ?brush:Brush.t -> ?color:Color.t -> ?pen:Pen.t -> ?dashed:Dash.t -> Path.t -> t (** Draw a path @param color the color of the path; default is black @param pen the pen used to draw the path; default is [Brush.Pen.default] @param dashed if given, the path is drawn using that dash_style. *) (* val draw_arrow : ?color:Color.t -> ?pen:Pen.t -> ?dashed:Dash.t -> Path.t -> t (** Draw a path with an arrow head; the optional arguments are the same as for {!draw} *) *) val fill : ?color:Color.t -> Path.t -> t (** Fill a contour given by a closed path @param color the color used to fill the area; default is black *) val draw_pic : Picture.t -> t (** draws a picture *) val externalimage : string -> [ `None | `Width of Num.t (** keep the proportion of the image *) | `Height of Num.t | `Inside of Num.t * Num.t (** must be inside a box of this height and width *) | `Exact of Num.t * Num.t] -> t (** insert an image given its filename - *EXPERIMENTAL* *) (** {2 Manipulating Commands} *) val nop : t (** A command that has no effect *) val append : t -> t -> t (** Append two commands to form a compound command *) val (++) : t -> t -> t (** Abbreviation for [append] *) val seq : t list -> t (** Group a list of commands to a single command *) val iter : int -> int -> (int -> t) -> t (** [iter m n f] builds a command that corresponds to the sequence of commands [f m; f (m+1); ... ; f(n)] *) val iterl : ('a -> t) -> 'a list -> t (** [iterl f l] builds a command that corresponds to the sequence of commands [f x1; f x2; ... ; f xn] for [l = [x1;x2;...;xn]] *) (** {2 Labels} *) type hposition = [ | `Center | `West | `East | `Left | `Right ] type vposition = [ `Center | `North | `South | `Top | `Bot | `Bottom ] type position = [ | hposition | vposition | `Northwest | `Northeast | `Southwest | `Southeast | `Upperleft | `Upperright | `Lowerleft | `Lowerright | `Topleft | `Topright | `Bottomleft | `Bottomright | `Upleft | `Upright | `Lowleft | `Lowright ] (** Positions - they are used at many places in Mlpost to indicate a direction or position. *) (** [label ~pos:`West pic p] puts picture [pic] at the left of the point [p] *) val label : ?pos:position -> Picture.t -> Point.t -> t (** Works like [label], but puts a dot at point [p] as well *) val dotlabel : ?pos:position -> Picture.t -> Point.t -> t end (** {2 Advanced graphical components} *) (** Rectangles, Circles, etc. *) module Shapes : sig (** Various Basic Geometric Shapes *) val round_rect : Num.t -> Num.t -> Num.t -> Num.t -> Path.t (** [round_rect w h rx ry] returns a rectangle of width [w] and height [h] with rounded corners. The rounded corners are arcs of an ellipse of radii [rx] and [ry]. [rx] (resp. [ry]) should be positive and smaller than [w/2] (resp. [h/2]). *) val rectangle : Num.t -> Num.t -> Path.t (** [rectangle w h] returns a rectangle of width [w] and height [h]. *) val ellipse : Num.t -> Num.t -> Path.t (** [ellipse rx ry] returns an ellipse of great axis [rx] and small axis [ry]. The ellipse is centered on the origin and aligned with the x axis. @param fill the color with which to fill the ellipse ; if no color is provided, it is not filled. @param stroke the color with which the ellipse's outline shall be drawn ; default is black. @param thickness the thickness of the pen used to draw the outline ; 1. is default *) val circle : Num.t -> Path.t val patatoid : Num.t -> Num.t -> Path.t (** See {!Box.patatoid}. *) val patatoid2 : Num.t -> Num.t -> Path.t (** See {!Box.patatoid2}. *) (* val arc_ellipse : ?fill:Color.t -> ?stroke:Color.t -> ?thickness:float -> ?close:bool -> Num.t -> Num.t -> float -> float -> Picture.t (** [arc_ellipse rx ry th1 th2] draws an arc of the ellipse of great axis [rx] and small axis [ry] starting at angle [th1] and ending at angle [th2] (in radians). The ellipse is centered on the origin and aligned with the x axis. @param fill the colod with which to fill the ellipse ; if no color is provided, it is not filled. @param stroke the color with which the ellipse's outline shall be drawn ; default is black. @param thickness the thickness of the pen used to draw the outline ; 1. is default @param close if true, the extremities of the arc are joined to the origin by straight lines, thus closing path. If [fill] is provided, then [close] will be true by default ; otherwise it is false. *) *) end (** A Box is a rectangle with some content and a (not necessarily rectangular) frame. Boxes can be placed, aligned and modified. *) module Box : sig (** Boxes *) (** The abstract type of boxes *) type t (** {2 Creating boxes} *) type style = | Rect | Circle | RoundRect | Patatoid | Patatoid2 | Ellipse | RoundBox | Custom of (Num.t -> Num.t -> Num.t * Num.t * Path.t) type 'a box_creator = ?dx:Num.t -> ?dy:Num.t -> ?name:string -> ?stroke:Color.t option -> ?pen:Pen.t -> ?dash:Dash.t -> ?fill:Color.t -> 'a -> t (** All functions used to create boxes take the following optional parameters : [dx] (resp. [dy]) is the horizontal (resp. vertical) padding between the box border and its contents ; [name], if present, is associated with the box and can be used to retrieve it using [get] ; [stroke] is the color used to draw the outline of the box ; when equal to [None], the outline will not be drawn ; [pen] is the pen used to draw the box's outline, if absent [Brush.Pen.default] is used ; [fill], if present, is the color used to fill the box. *) val empty : ?width:Num.t -> ?height:Num.t -> ?style:style -> ?name:string -> ?stroke:Color.t option -> ?pen:Pen.t -> ?dash:Dash.t -> ?fill:Color.t -> unit -> t (** the empty box *) val empty_from_box : ?style:style -> ?name:string -> ?stroke:Color.t option -> ?pen:Pen.t -> ?dash:Dash.t -> ?fill:Color.t -> t -> t (** the empty box with the same position and dimension as the box *) val pic : ?style:style -> Picture.t box_creator (** [pic p] creates a new box containing the picture [p] *) val path : ?style:style -> Path.t box_creator (** [path p] creates a new box containing the path [p] *) val tex : ?style:style -> string box_creator (** [tex s] creates a new box containing the LaTeX string [s] @img tex.png *) val box : ?style:style -> t box_creator (** [box b] creates a new box containing the box [b] *) val circle : t box_creator (** [circle pic] creates a circle box containing the picture [pic]. Optional padding is given by arguments [dx] and [dy]; default is 2bp. @img circle.png *) val ellipse : t box_creator (** [ellipse pic] creates a elliptic box containing the picture [pic]. Optional padding is given by arguments [dx] and [dy]; default is 2bp @img ellipse.png *) val rect : t box_creator (** [rect pic] creates a rectangular box containing the picture [pic]. Optional padding is given by arguments [dx] and [dy]; default is 2bp. @img rect.png *) val round_rect : t box_creator (** [round_rect pic] creates a rectangular box containing the picture [pic], with rounded corners. Optional padding is given by [dx] and [dy]; default is 2bp @img round_rect.png *) val patatoid : t box_creator (** [patatoid pic] creates an undefined, vaguely rectangular box containing the picture [pic]. It may happen that the content overlaps with the box. @img patatoid.png *) val patatoid2 : t box_creator (** [patatoid2 pic] creates an undefined, vaguely rectangular box containing the picture [pic], which is guaranteed to be fully contained in the patatoid. *) val round_box : t box_creator (*** val round_rect_gen : ?dx:Num.t -> ?dy:Num.t -> ?rx:Num.t -> ?ry:Num.t -> Point.t -> Picture.t -> t (** [round_rect_gen p pic] creates a rectangular box of center [p] and of contents [pic], with rounded corners of radii [rx] and [ry]. Optional padding is given by [dx] and [dy] ; default is 2bp *) ***) (** Get the bounding path of a box *) val bpath : t -> Path.t (** {2 Special points on a box} *) val ctr : t -> Point.t (** @img ctr.png *) val north : t -> Point.t (** @img north.png *) val south : t -> Point.t (** @img south.png *) val west : t -> Point.t (** @img west.png *) val east : t -> Point.t (** @img east.png *) val north_west : t -> Point.t (** @img north_west.png *) val south_west : t -> Point.t (** @img south_west.png *) val north_east : t -> Point.t (** @img north_east.png *) val south_east : t -> Point.t (** @img south_east.png *) type vposition = [ |Command.vposition | `Custom of t -> Num.t] type hposition = [ |Command.hposition | `Custom of t -> Num.t] type position = [ |Command.position | `Custom of t -> Point.t] val corner : position -> t -> Point.t val opposite_position : position -> position (** Return the opposite position of a position (west for east, southeast for northwest, center for center, ...). *) (** {2 Operators} *) val height : t -> Num.t (** return the height of the box @img height.png *) val width : t -> Num.t (** return the width of the box @img width.png *) val shift : Point.t -> t -> t (** [shift pt x] shifts the box [x] about the point [pt] @img shift.png *) val center : Point.t -> t -> t (** [center pt x] centers the box [x] at the point [pt] @img center.png *) val draw : ?debug:bool -> t -> Command.t (** Draws a box @param debug if set to to true, the bounding path and the center of the box are drawn as well, default is false *) val group : ?style:style -> t list box_creator (** [group bl] groups a list of boxes [bl] into a single box *) (** {2 Boxes alignment} *) val halign : ?pos:vposition -> Num.t -> t list -> t list (** [halign ~pos y l] vertically moves the boxes in [l] such that the vertical position given by [pos] is equal to [y]. The default value of [pos] is `Center, so by default this function moves each box such that the y coordinate of its center is [y]. The horizontal position of each box is unchanged. @img halign.png *) val valign : ?pos:hposition -> Num.t -> t list -> t list (** the vertical counterpart of [valign]. *) val hplace : ?padding:Num.t -> ?pos:position -> ?min_width:Num.t -> ?same_width:bool -> t list -> t list (** [hplace l] places the boxes of [l] horizontally, from left to right following the order of list elements, without changing their vertical position. @param min_width minimum width of all boxes; default is zero @param same_width if [true], all boxes are of same width, and at least of [min_width]; default is false @img hplace.png *) val vplace : ?padding:Num.t -> ?pos:position -> ?min_height:Num.t -> ?same_height:bool -> t list -> t list (** the vertical counterpart of [hplace] *) val hbox : ?padding:Num.t -> ?pos:position -> ?style:style -> ?min_width:Num.t -> ?same_width:bool -> t list box_creator (** places the given boxes horizontally, aligning them horizontally, and returns a box containing these boxes as sub-components. Leave the first box at its place. [hbox l] actually gives the same result as [group (hplace (halign l))]. @param padding horizontal padding used to separate the boxes; defaults to 0 @param pos used to determine the way boxes are aligned; defaults to [`Center] @img hbox.png *) val hbox_list : ?padding:Num.t -> ?pos:position -> ?min_width:Num.t -> ?same_width:bool -> t list -> t list (** as [hbox], but does not group the resulting boxes into a surrounding box; it returns the list of placed boxes instead. [hbox_list l] is equal to [hplace (halign l)]. *) val vbox : ?padding:Num.t -> ?pos:position -> ?style:style -> ?min_height:Num.t -> ?same_height:bool -> t list box_creator (** aligns the given boxes vertically and returns a box containing these boxes as sub-components. Leave the first box at its place. @param padding vertical padding used to separate the boxes @param pos used to determine the way boxes are aligned *) val vbox_list : ?padding:Num.t -> ?pos:position -> ?min_height:Num.t -> ?same_height:bool -> t list -> t list (* as vbox_list, but does not group the resulting boxes into a surrounding box *) val tabular : ?hpadding:Num.t -> ?vpadding:Num.t -> ?pos:Command.position -> ?style:style -> ?name:string -> ?stroke:Color.t option -> ?pen:Pen.t -> ?dash:Dash.t -> ?fill:Color.t -> t array array -> t (** aligns the given boxes both vertically and horizontally and returns a box containing all these boxes (with rows as first sub-components, and then individual boxes as sub-components of each row). Columns (resp. rows) are separated by [hpadding] (resp. [vpadding]); both default to 0. Alignment within columns and rows is controlled using [pos]. The arrays for rows must have the same lengths; otherwise [Invalid_argument] is raised. *) val tabularl : ?hpadding:Num.t -> ?vpadding:Num.t -> ?pos:Command.position -> ?style:style -> ?name:string -> ?stroke:Color.t option -> ?pen:Pen.t -> ?dash:Dash.t -> ?fill:Color.t -> t list list -> t (** similar to [tabular], but using lists instead of arrays *) val tabulari : ?hpadding:Num.t -> ?vpadding:Num.t -> ?pos:Command.position -> ?style:style -> ?name:string -> ?stroke:Color.t option -> ?pen:Pen.t -> ?dash:Dash.t -> ?fill:Color.t -> int -> int -> (int -> int -> t) -> t (** similar to [tabular], but using a matrix defined with a function *) val hblock : ?padding:Num.t -> ?pos:Command.position -> ?name:string -> ?stroke:Color.t option -> ?pen:Pen.t -> ?dash:Dash.t -> ?min_width:Num.t -> ?same_width:bool -> t list -> t (** [hblock bl] aligns the boxes of [bl] horizontally and surround them with new rectangular boxes of the same height; all these new boxes are packed together into the returned box. @param min_width minimum width of all boxes; default is zero @param same_width if [true], all boxes are of same width, and at least of [min_width]; default is false*) val vblock : ?padding:Num.t -> ?pos:Command.position -> ?name:string -> ?stroke:Color.t option -> ?pen:Pen.t -> ?dash:Dash.t -> ?min_height:Num.t -> ?same_height:bool -> t list -> t (** similar to [hblock], with vertical alignment. @param min_height minimum height of all boxes; default is zero @param same_height if [true], all boxes are of same height, and at least of [min_height]; default is false*) val grid : ?hpadding:Num.t -> ?vpadding:Num.t -> ?pos:Command.position -> ?stroke:Color.t option -> ?pen:Pen.t -> ?dash:Dash.t -> t array array -> t (** Aligns the given boxes in a way that is similar to [hblock] and [vblock]: boxes are aligned in a grid where all cells have the same size. Each one of these cells is a box containing the original corresponding box. *) val gridl : ?hpadding:Num.t -> ?vpadding:Num.t -> ?pos:Command.position -> ?stroke:Color.t option -> ?pen:Pen.t -> ?dash:Dash.t -> t list list -> t (** similar to [grid], but using lists instead of arrays *) val gridi : ?hpadding:Num.t -> ?vpadding:Num.t -> ?pos:Command.position -> ?stroke:Color.t option -> ?pen:Pen.t -> ?dash:Dash.t -> int -> int -> (int -> int -> t) -> t (** similar to [gridi], but using a matrix defined with a function *) val place : position -> ?pos: position -> ?padding: Num.t -> t -> t -> t (** Place a box relatively to another box. [place `East a] is a function which places a box at the east of [a]. Thus, [place `East a b] returns a copy of [b] placed at the east of [a]. [place posa ~pos: posb ~padding a b] returns a new box [c] which is obtained by moving [b] to place the [posa] point of [a] on top of the [posb] point of [b], and then padding the result by [padding] in direction [posa]. Default value of [posb] is the opposite direction of [posa] wrt. the center (see {!opposite_position}). Default value of [padding] is zero. The padding argument multiplies a unit vector which goes from the center of [a] to the corner of [a] indicated by [posa]. This effectively places point [posa] of [a] at exactly [padding] units of point [posb] of [b], in direction [posa]. This also means that for diagonal directions, the actual direction will change according to the width / height ratio of [a]. *) (** {2 Sub-boxes accessors} *) val nth : int -> t -> t (** [nth i b] returns the [i]-th sub-box of [b]. The first sub-box has index 0. Raises [Invalid_argument] if there is no such sub-box. *) val get : string -> t -> t (** [get n b] returns the sub-box of [b] of name [n], if any, and raises [Invalid_argument] otherwise. The behavior is not specified if [b] contains several sub-boxes with name [n]. *) val sub : t -> t -> t (** [sub b1 b] returns the sub-box of [b] which has the same name as [b1], if any, and raises [Invalid_argument] otherwise. The behavior is not specified if [b] contains several sub-boxes with the name of [b1]. *) val elts : t -> t array (** [elts b] returns the sub-boxes of [b]; returns the empty array for the empty box or a box containing a picture. *) (** {2 Specials Points} *) val setp : string -> Point.t -> t -> t val getp : string -> t -> Point.t val getpx : string -> t -> Num.t val getpy : string -> t -> Num.t (** {2 Box properties} *) val get_fill : t -> Color.t option val set_fill : Color.t -> t -> t val get_stroke : t -> Color.t option val set_stroke : Color.t -> t -> t val clear_stroke : t -> t val get_name : t -> string option val set_name : string -> t -> t val get_pen : t -> Pen.t option val set_pen : Pen.t -> t -> t val set_height : Command.vposition -> Num.t -> t -> t val set_width : Command.hposition -> Num.t -> t -> t val get_dash : t -> Dash.t option val set_dash : Dash.t -> t -> t val clear_dash : t -> t val set_height2 : vposition -> Num.t -> vposition -> Num.t -> t -> t (** set_height2 `North y1 `South y2 b return the box b with its height and center chosen such as the ordinate of the top (because of `North) of the box is at y1 and the ordinate of its south is at y2*) val set_width2 : hposition -> Num.t -> hposition -> Num.t-> t -> t val set_size : Command.position -> width:Num.t -> height:Num.t -> t -> t val same_height : ?pos:vposition -> t list -> t list val same_width : ?pos:hposition -> t list -> t list val same_size : ?pos:position -> t list -> t list val set_post_draw : (t -> Command.t) -> t -> t val clear_post_draw : t -> t val set_pre_draw : (t -> Command.t) -> t -> t val clear_pre_draw : t -> t (** {2 Misc.} *) val shadow : t -> t val cpath : ?style:Path.joint -> ?outd:Path.direction -> ?ind:Path.direction -> ?sep:Num.t -> t -> t -> Path.t (** the path that connects 2 boxes and stops at the box boundaries *) val cpath_left : ?style:Path.joint -> ?outd:Path.direction -> ?ind:Path.direction -> t -> Point.t -> Path.t (** the path that connects a box and a point and stops at the box boundaries *) val cpath_right : ?style:Path.joint -> ?outd:Path.direction -> ?ind:Path.direction -> Point.t -> t -> Path.t (** the path that connects a box and a point and stops at the box boundaries *) val transform : Transform.t -> t -> t val scale : Num.t -> t -> t val rotate : float -> t -> t val shift : Point.t -> t -> t val yscale : Num.t -> t -> t val xscale : Num.t -> t -> t (** {2 Boxlike : An argument for functor of object that are similar to box} *) val set_pos : Point.t -> t -> t (** same as center *) end (** Draw arrows and build new forms of arrows. *) module Arrow : sig (** Draw simple or complex arrows. *) (** To draw an arrow, choose your arrow [kind], then call the [draw] function (giving the path that the arrow will follow) or the [draw2] function (giving the starting and ending points of the arrow). If your favorite arrow [kind] does not exist, use the tools from this module to build your own! *) type kind (** The abstract type for arrow kinds. *) (** {2 Drawing Arrows} *) (** If you need to place a label which is not TeX but any picture, if you need to place it at a symbolic position on the path, or if you need to place more than one label, you cannot do it directly using the [draw] commands. First draw the arrow, then use functions such as {!Command.label}. *) val simple : ?color:Color.t -> ?brush:Brush.t -> ?pen:Pen.t -> ?dashed:Dash.t -> Path.t -> Command.t (** Draw a simple arrow following the given path. @param color the color of the arrow @param pen the pen to use to draw the body of the arrow @param dashed the dash pattern to use to draw the body of the arrow *) val draw: ?kind: kind -> ?tex: string -> ?pos: float -> ?anchor: Command.position -> Path.t -> Command.t (** Draw an arrow following the given path. @param kind the kind of arrow (default is {!triangle_full}) @param tex add a LaTeX label @param pos label position on the path @param anchor label anchor *) val point_to_point: ?kind: kind -> ?tex: string -> ?pos: float -> ?anchor: Command.position -> ?outd: Path.direction -> ?ind: Path.direction -> Point.t -> Point.t -> Command.t (** Use [point_to_point a b] to draw an arrow from [a] to [b]. @param kind the kind of arrow (default is {!triangle_full}) @param tex add a LaTeX label @param pos label position on the path @param anchor label anchor @param outd the outgoing direction, at the beginning of the arrow @param ind the ingoing direction, at the end of the arrow *) val box_to_box: ?kind: kind -> ?tex: string -> ?pos: float -> ?anchor: Command.position -> ?outd: Path.direction -> ?ind: Path.direction -> Box.t -> Box.t -> Command.t (** Use [box_to_box] to draw an arrow from [a] to [b], stopping at the box boundaries. The arguments are the same as those of [point_to_point]. *) val point_to_box: ?kind: kind -> ?tex: string -> ?pos: float -> ?anchor: Command.position -> ?outd: Path.direction -> ?ind: Path.direction -> Point.t -> Box.t -> Command.t (** Use [point_to_box] to draw an arrow from [a] to [b], stopping at the box boundaries. The arguments are the same as those of [point_to_point]. *) val box_to_point: ?kind: kind -> ?tex: string -> ?pos: float -> ?anchor: Command.position -> ?outd: Path.direction -> ?ind: Path.direction -> Box.t -> Point.t -> Command.t (** Use [box_to_point] to draw an arrow from [a] to [b], stopping at the box boundaries. The arguments are the same as those of [point_to_point]. *) (** {2 Built-in Kinds} *) val classic: kind (** A simple arrow with one line and two straight lines for the head. *) val triangle: kind (** A simple arrow with a triangular head. Same as [classic] but with an extra line and some clipping. *) val triangle_full: kind (** A simple arrow with a triangular head filled with black. *) val implies: kind (** An arrow made of two parallel lines and a classic head. *) val iff: kind (** An arrow made of two parallel lines, a classic head and a classic foot. *) (** {2 Heads} *) type head_description (** The type of head descriptions (see [make_head] and [head] below). *) val make_head: ?cut: Path.t -> Command.t -> head_description (** Head description constructor. The command parameter is used to draw the head. @param cut a path that can be used to cut the arrow body lines (only used by heads and feet, not by belts) *) type head = Point.t -> Point.t -> head_description (** If [h] is a head, [h p d] returns a head description used to draw the head at point [p] with direction [d]. Direction [d] is normalized before being given to the function. *) val head_classic : ?color:Color.t -> ?brush:Brush.t -> ?pen:Pen.t -> ?dashed:Dash.t -> ?angle:float -> ?size:Num.t -> head (** A simple head with two straight lines. @param color the color of the head; default is black @param pen the pen used to draw the head; default is [Brush.Pen.default] @param dashed if given, the head is drawn using that dash_style @param angle the angle between the two lines in degrees, default is 60 degrees @param size the length of the two lines, default is 4bp *) val head_triangle : ?color:Color.t -> ?brush:Brush.t -> ?pen:Pen.t -> ?dashed:Dash.t -> ?angle:float -> ?size:Num.t -> head (** Same as [head_classic] except that the two lines are joined together to form a triangle. *) val head_triangle_full : ?color:Color.t -> ?angle:float -> ?size:Num.t -> head (** Same as [head_triangle] except that the triangle is not drawn (hence the absence of pen properties) but is filled with the given [color]. *) (** {2 Building Your Own Kinds} *) (** Start from the empty kind [empty] and add features to it using [add_line], [add_head], ... *) val empty: kind (** The empty kind with no line nor head. *) val add_line: ?brush:Brush.t -> ?dashed: Dash.t -> ?color: Color.t -> ?pen: Pen.t -> ?from_point: float -> ?to_point: float -> ?dist: Num.t -> kind -> kind (** Add a line to a body. The line will be parallel to the path used to draw the arrow. @param dashed the dash style used to draw the line (default is plain) @param color the color of the line (default is black) @param pen the pen used to draw the line (default is [Brush.Pen.default]) @param from_point from [0.] (foot of the arrow) to [1.] (head of the arrow), the line will start from this point @param to_point from [0.] (foot of the arrow) to [1.] (head of the arrow), the line will end at this point @param dist the distance between the path of the arrow and this line (positive values are on the right of the arrows) *) val add_head: ?head: head -> kind -> kind (** Add a head at the end of the arrow. @param head the kind of head to add (default is {!head_classic}) *) val add_foot: ?head: head -> kind -> kind (** Add a foot (an inverted head) at the beginning of the arrow. @param head the kind of head to add (default is {!head_classic}) *) val add_belt: ?clip: bool -> ?rev: bool -> ?point: float -> ?head: head -> kind -> kind (** Add an arrow head at any point of an arrow. @param clip if [true], the arrow lines will be clipped after the belt (or before if the [rev] is [true]) (default is [false]) @param rev if [true], the head will be drawn in the opposite direction (default is [false]) @param point the point where to draw the arrow ([0.] for the beginning, and [1.] for the end, or any number in-between) (default is [0.5]) @param head the kind of head to add (default is {!head_classic}) *) (** {2 Miscellaneous} *) (** Warning: the following functions might be either deleted, modified and / or moved somewhere else. Don't use them if you need some backward compatibility. *) val draw_thick : ?style:Path.joint -> ?boxed:bool -> ?line_color:Color.t -> ?fill_color:Color.t -> ?outd:Path.direction -> ?ind:Path.direction -> ?width:Num.t -> ?head_length:Num.t -> ?head_width:Num.t -> Point.t -> Point.t -> Command.t (** Draw a thick arrow. *) end (** {2 Helpers and Extensions} *) (** A few helper functions *) module Helpers : sig val dotlabels : ?pos:Command.position -> string list -> Point.t list -> Command.t val draw_simple_arrow : ?color:Color.t -> ?pen:Pen.t -> ?dashed:Dash.t -> ?style:Path.joint -> ?outd:Path.direction -> ?ind:Path.direction -> Point.t -> Point.t -> Command.t val draw_label_arrow : ?color:Color.t -> ?pen:Pen.t -> ?dashed:Dash.t -> ?style:Path.joint -> ?outd:Path.direction -> ?ind:Path.direction -> ?pos:Command.position -> Picture.t -> Point.t -> Point.t -> Command.t val draw_labelbox_arrow : ?color:Color.t -> ?pen:Pen.t -> ?dashed:Dash.t -> ?style:Path.joint -> ?outd:Path.direction -> ?ind:Path.direction -> ?pos:Command.position -> Box.t -> Point.t -> Point.t -> Command.t val box_arrow : ?within:Box.t -> ?color:Color.t -> ?pen:Pen.t -> ?dashed:Dash.t -> ?style:Path.joint -> ?outd:Path.direction -> ?ind:Path.direction -> ?sep:Num.t -> Box.t -> Box.t -> Command.t (** Draw an arrow between two boxes. The options [pen], [dashed], [color] change the drawing of the arrow. [outd] and [ind] specify the outgoing and ingoing direction. [sep] specifies the distance of the arrow ends to both boxes. If [within] is set, the boxes will be searched within the box [within]. *) val box_line : ?within:Box.t -> ?color:Color.t -> ?pen:Pen.t -> ?dashed:Dash.t -> ?style:Path.joint -> ?outd:Path.direction -> ?ind:Path.direction -> ?sep:Num.t -> Box.t -> Box.t -> Command.t val box_label_arrow : ?within:Box.t -> ?color:Color.t -> ?pen:Pen.t -> ?dashed:Dash.t -> ?style:Path.joint -> ?outd:Path.direction -> ?ind:Path.direction -> ?sep:Num.t -> ?pos:Command.position -> Picture.t -> Box.t -> Box.t -> Command.t val box_label_line : ?within:Box.t -> ?color:Color.t -> ?pen:Pen.t -> ?dashed:Dash.t -> ?style:Path.joint -> ?outd:Path.direction -> ?ind:Path.direction -> ?sep:Num.t -> ?pos:Command.position -> Picture.t -> Box.t -> Box.t -> Command.t val box_labelbox_arrow : ?within:Box.t -> ?color:Color.t -> ?pen:Pen.t -> ?dashed:Dash.t -> ?style:Path.joint -> ?outd:Path.direction -> ?ind:Path.direction -> ?sep:Num.t -> ?pos:Command.position -> Box.t -> Box.t -> Box.t -> Command.t (*** val hboxjoin : ?color:Color.t -> ?pen:Pen.t -> ?dashed:Dash.t -> ?dx:Num.t -> ?dy:Num.t -> ?pos:Command.position -> ?spacing:Num.t -> Picture.t list -> Command.t ***) end (** Create and draw trees *) module Tree : sig (** This module provides high-level means for creating and drawing Trees *) type t (** The type of trees *) (** The style of arrows between nodes *) type arrow_style = Directed (** edges are directed and an arrow is drawn at the end of an edge *) | Undirected (** edges are undirected and no arrow is drawn *) (** There are several styles available for edges *) type edge_style = Straight (** edges are straight lines between nodes *) | Curve (** edges are curved lines between nodes *) | Square (** edges are straight lines and branch out from the sides of nodes *) | HalfSquare (** edges are straight lines and branch out from below nodes *) (** {2 Creation} *) val leaf : Box.t -> t (** [leaf b] creates a leaf with Box [b]. *) val node : ?ls:Num.t -> ?cs:Num.t -> ?arrow_style:arrow_style -> ?edge_style:edge_style -> ?stroke:Color.t -> ?brush:Brush.t -> ?pen:Pen.t -> ?sep:Num.t -> Box.t -> t list -> t (** [node label children] creates a node with label [label] and a list of children [children]. Default arrow_style is [Directed]. Default edge_style is [Straight]. - [ls] (level sep): vertical distance between levels. The default value is 1.0. A negative value draws the tree upward. - [cs] (children sep): horizontal distance between siblings. The default value is 0.2. Optional arguments are the same as in [leaf]. *) val nodel : ?ls:Num.t -> ?cs:Num.t -> ?arrow_style:arrow_style -> ?edge_style:edge_style -> ?stroke:Color.t -> ?brush:Brush.t -> ?pen:Pen.t -> ?sep:Num.t -> Box.t -> (t * (Command.position * Picture.t)) list -> t (** Similar to [node] but with labels on edges. Labels are taken into account only when [edge_style] is [Straight]. *) val bin : ?ls:Num.t -> ?cs:Num.t -> ?arrow_style:arrow_style -> ?edge_style:edge_style -> ?stroke:Color.t -> ?brush:Brush.t -> ?pen:Pen.t -> ?sep:Num.t -> Box.t -> t -> t -> t (** [bin label l r] creates a binary node with label [label] and children [l] and [r]. Optional arguments are the same as in [leaf]. *) val to_box : t -> Box.t val draw : ?debug:bool -> t -> Command.t module Simple : sig type t val leaf : Box.t -> t val node : ?ls:Num.t -> ?cs:Num.t -> ?arrow_style:arrow_style -> ?edge_style:edge_style -> ?stroke:Color.t -> ?brush:Brush.t -> ?pen:Pen.t -> ?sep:Num.t -> ?valign:Command.position -> ?halign:Command.position -> Box.t -> t list -> t (** a simple tree placement algorithm: align all subtrees horizontally , and place the parent node above. Default arrow_style is [Directed]. Default edge_style is [Straight]. @param ls (level sep): vertical distance between levels. The default value is 1.0. A negative value draws the tree upward. @param cs (children sep): horizontal distance between siblings. The default value is 0.2. @param halign change alignment of children (default: [`Top]) @param valign change alignment of parent node wrt. children (default: [`Children]) *) val bin : ?ls:Num.t -> ?cs:Num.t -> ?arrow_style:arrow_style -> ?edge_style:edge_style -> ?stroke:Color.t -> ?brush:Brush.t -> ?pen:Pen.t -> ?sep:Num.t -> Box.t -> t -> t -> t (* [bin t1 t2] is the same as [node [t1;t2] ] *) val to_box : t -> Box.t val draw : ?debug:bool -> t -> Command.t end end (** EXPERIMENTAL: A new way of placing trees. *) module Tree_adv : sig (** This module provides even more high-level means for placing trees. *) type 'a t = Node of 'a * 'a t list (** The type of polymorphic trees *) (** {2 Functions for placement} *) module Place (X : Signature.Boxlike) : sig val gen_place : place:(Box.t t -> Box.t) -> X.t t -> X.t t (** This is a generic function for placing trees, provided that the user can give us the following functions: @param place a function which knows how to place a tree of boxes - it should return a box where all the boxes of the input tree appear. *) val place : ?ls:Num.t -> ?cs:Num.t -> ?valign:Box.position -> ?halign:Box.position -> X.t t -> X.t t (** This is an instance of [gen_place] using the tree drawing algorithm from the module {!Tree}. *) end val gen_draw_arrows : 'c -> style:(Point.t -> Point.t -> 'c) -> corner:(Box.position -> 'a -> Point.t) -> 'a t -> 'c t (** draws arrows from a node to its children with a given style *) val draw : ('a -> Box.t) -> 'a t -> Command.t (** Draws a tree that has already been placed when one knows how to draw its elements. *) (** {2 Useful functions} *) val map : ('a -> 'b) -> 'a t -> 'b t (** apply a function everywhere in the tree *) val map2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t (** [map2 f] takes two trees of identical structure and applies the function [f] to every pair of nodes. Raise [Invalid_argument] if the trees do not have the same structure. *) val combine : 'a t -> 'b t -> ('a * 'b) t (** Transform a pair of trees into a tree of pairs. Raise [Invalid_argument] if the trees do not have the same structure. *) val split : ('a * 'b) t -> 'a t * 'b t (** Transform a tree of pairs into a pair of trees. *) val root_map : ('a option -> 'a -> 'b) -> 'a t -> 'b t (** [root_map f t] calls [f (Some father) node] for each node of [t] and its father. It calls [f None root], where [root] is the root of the once, once at the beginning. A tree having the same structure is built with the results. *) val map_children : ('a -> 'a list -> 'b) -> 'a t -> 'b t (** [map_children f t] calls [f node children] for each node of [t] and its children. A tree having the same structure is built with the results *) val fold : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a (** Traverse the tree in a bottom-up, left-to-right order *) val filter : ('a -> bool) -> 'a t -> 'a t (** filter f t If for a node n of t f n is false then it doesn't appear in the result as well as its descendants. If f is false for the root node, invalid_argument is raised *) val filter_option : ('a -> 'b option) -> 'a t -> 'b t (** Suppress a subtree depending on a condition on the node *) val wrap_corner_box : ('a -> Box.t) -> ( corner : (Box.position -> 'a -> Point.t) -> 'c) -> 'c (** [wrap_corner_box give_box f] returns [f] where its argument corner has been set *) (** Tools for overlay aware trees *) module Overlays : sig (** This module provides a type to associate an interval of time to a value, to control its visibility *) type interval = | Bet of int * int (** \[|a,b|\] *) | Bef of int (** \]|-oo,a|\] *) | Aft of int (** \[|a,+oo|\[ *) | Nev (** emptyset *) | Alw (** N *) (** This type describes an interval of discrete points of time *) val in_interval : int -> interval -> bool (** test if an integer is in an interval *) val min_interval : int -> interval -> int (** The minimum between the integer argument and the beginning of the interval; returns the integer argument in the cases [Nev] and [Alw] *) val max_interval : int -> interval -> int (** The dual of [min_interval] *) val min_tree : ('a -> interval) -> 'a t -> int (** The first moment of the tree to appear, not considering [Nev] and [Alw] *) val max_tree : ('a -> interval) -> 'a t -> int (** The last moment of the tree to appear, not considering [Nev] and [Alw] *) type 'a spec = (interval * 'a) list (** A spec is a list of objects associated with a visibility interval *) val assoq : int -> 'a spec -> 'a (** returns the first element which is visible in the specification; raises [Not_found] if no element is visible *) val max : ('a -> Num.t) -> ('b * 'a) list -> Num.t (** given a function to compute a numeric from an ['a], and a list of objects [('b,'a)], return the maximal numeric from that list; intended to be used with width and height functions for objects and with a ['a spec list] *) val set_pos : (Point.t -> 'a -> 'b) -> Point.t -> 'a spec -> 'b spec (** Given a function to move objects of type ['a], return a function to move functions of type ['a spec] *) end module Overlays_Boxlike (X : Signature.Boxlike): Signature.Boxlike with type t = X.t Overlays.spec end (** Create simple diagrams by placing objects in a table. Deprecated. *) module Diag : sig (** Diagrams. *) (** This module permits to create diagrams in a very simple and yet quite flexible fashion. It permits to specify content, form and color of nodes as well as color, form and labels of arrows between nodes. Nodes have to be placed by hand, though *) (** {2 Creation} *) type node (** The abstract type of nodes *) type node_style = Box.t -> Box.t (** The type for node styles; It corresponds to the type of the box creation functions in the {!Box} module *) val node : ?style:node_style -> ?fill:Color.t -> ?boxed:bool -> float -> float -> Box.t -> node (** Construct a node at a given position with a given content in Latex format and a box style *) type t (** The abstract type of diagrams *) val create : node list -> t (** Create a diagram that consists of the given nodes *) type dir = Up | Down | Left | Right | Angle of float val arrow : t -> ?lab:string -> ?line_width:Num.t -> ?boxed:bool -> ?line_color:Color.t -> ?fill_color:Color.t -> ?pos:Command.position -> ?head:bool -> ?dashed:Dash.t -> ?outd:dir -> ?ind:dir -> node -> node -> unit (** [arrow d n1 n2] adds an arrow between n1 and n2 in the diagram d, by side effect. @param lab The label of the arrow, in Latex format @param pos The position of the label, relative to the arrow @param line_width Draws a thick arrow of that width, if present (experimental) @param head If true, the arrow has a head. Otherwise, it's just a line. @param outd The outgoing direction of the arrow @param ind The ingoing direction of the arrow *) (** {2 Drawing} *) val draw : ?scale:(float -> Num.t) -> ?style:node_style -> ?boxed:bool -> ?fill:Color.t -> ?stroke:Color.t -> ?pen:Pen.t -> t -> Command.t (** Draws the diagram. @param scale The distance between nodes; default is 40 bp @param style The style of nodes: circular or rectangular (default is circular) @param boxed The border is drawn if set (default is true) @param fill The color to fill nodes @param stroke The color to draw arrows @param pen The pen used for arrows *) end (** A simple and limited way of plotting functions from int to int. *) module Plot : sig (** Plots. *) (** This module helps drawing grids and plotting functions. *) type skeleton (** The abstract skeleton for grids, axes and functions *) val mk_skeleton : int -> int -> Num.t -> Num.t -> skeleton (** [mk_skeleton w h dx dy] builds a skeleton of width [w] and height [h], each cell being [dx] units wide and [dy] units high. *) type labels = int -> Num.t -> Picture.t option type ticks = (Num.t * Pen.t) option type drawing = Stepwise | Normal val draw_grid : ?hdash:(int -> Dash.t) -> ?vdash:(int -> Dash.t) -> ?hpen:(int -> Pen.t) -> ?vpen:(int -> Pen.t) -> ?color:Color.t -> skeleton -> Command.t val draw_axes : ?hpen:Pen.t -> ?vpen:Pen.t -> ?hlabel:labels -> ?vlabel:labels -> ?ticks:ticks -> ?closed:bool -> ?hcaption:Picture.t -> ?vcaption:Picture.t -> skeleton -> Command.t val draw_simple_axes : ?hpen:Pen.t -> ?vpen:Pen.t -> string -> string -> skeleton -> Command.t val draw_func : ?pen:Pen.t -> ?drawing:drawing -> ?style:Path.joint -> ?dashed:Dash.t -> ?color:Color.t -> ?label:(Picture.t * Command.position * int) -> ?from_x:int -> ?to_x:int -> (int -> float) -> skeleton -> Command.t end (** A simple and limited way of plotting functions from float to float. *) module Real_plot : sig type 'a curve (** 'a store the information about : - the way the curve is drawn (style and color) - the label used in the legend *) val curve : (float -> float) -> 'a -> 'a curve (** create a curve from a function and some information of drawing *) val curve_opt : (float -> float option) -> 'a -> 'a curve (** create a curve from a function and some information of drawing. If the function return None the function is not defined on this value *) val curve_l : (float -> float option) list -> 'a -> 'a curve (** create a curve from multiple function and some information of drawing. The different functions symbolize different part of the curve which mustn't be connected *) val draw : ?logarithmic : bool -> (* use a logarithmic scale for ordinate *) ?curve_brush : ('a -> Brush.t) -> (* how to draw a curve *) ?label : ('a -> string) -> (* return the label to use in the legend. If no function is given the legend is not drawn *) ?ymin : float -> ?ymax : float -> xmin : float -> xmax : float -> pitch : float -> width : Num.t -> height : Num.t -> 'a curve list -> Command.t (* Draw a graph. If concrete is supported (Concrete.supported) the label of ticks on the axes will not overlap *) end (** Draw Bar diagrams (Histograms). *) module Hist : sig (** Histograms. *) (** This module draws histograms. *) type 'a labels = Values | User of 'a list val simple : ?width:Num.t -> ?height:Num.t -> ?padding:Num.t -> ?fill:Color.t list -> ?perspective: bool -> ?hcaption:Picture.t -> ?vcaption:Picture.t -> ?histlabel:Command.vposition * Picture.t labels -> ?vlabel:Plot.labels -> ?hlabel:Picture.t list -> float list -> Command.t (** [simple l] draws an histogram from a list [l] of floating-point values. @param width Total width of the histogram (default: 100 bp) @param height Total height for the histogram (default: 200 bp) @param fill The colors used to draw the successive blocks; it is used circularly @param padding Horizontal space between two blocks @param hcaption See module Plot @param vcaption See module Plot @param hlabel Labels for each block @param vlabel See module Plot @param histlabel Add a label to each block; the first component controls the placement of the label; the second component, of type [insideBox], controls the label itself, which is either the numerical value of the block (i.e. the float) or a user picture *) val compare : ?width:Num.t -> ?height:Num.t -> ?padding:Num.t -> ?fill:Color.t list -> ?perspective: bool -> ?hcaption:Picture.t -> ?vcaption:Picture.t -> ?histlabel:Command.vposition * Picture.t list labels -> ?vlabel:Plot.labels -> ?hlabel:Picture.t list -> float list list -> Command.t (** [compare l] draws a comparative histogram from a list [l] of floating-point lists. For optional arguments, see function [simple] above. *) val stack : ?width:Num.t -> ?height:Num.t -> ?padding:Num.t -> ?fill:Color.t list -> ?perspective: bool -> ?hcaption:Picture.t -> ?vcaption:Picture.t -> ?histlabel:Command.vposition * Picture.t list labels -> ?vlabel:Plot.labels -> ?hlabel:Picture.t list -> float list list -> Command.t (** [compare l] draws a stacked histogram from a list [l] of floating-point lists. For optional arguments, see function [simple] above. *) end (** Radar diagrams. *) module Radar : sig (** This module draws radar diagrams.*) val stack : ?radius:Num.t -> ?color:Color.t list -> ?pen:Pen.t -> ?style:Dash.t list -> ?ticks:float -> ?label:string list -> ?scale:float list -> float list list -> Picture.t (** [stack l] builds a picture from a list [l] of floating-point lists. The radars are all drawn on the same picture. Each sublist represents one radar datas. All sublists must have the same length. @param radius The radius of the whole picture @param pen The pen used to draw the radars @param color The colors used to draw each radar; it is used circularly @param style The dash-styles used to draw each radar; it is used circularly @param ticks The interval between each ticks along the axes (relative to the values) @param scale The size of every axe, relative to the values; when not specified, the maximal value along each axe is chosen *) val compare : ?radius:Num.t -> ?color:Color.t list -> ?fill:bool -> ?pen:Pen.t -> ?style:Dash.t list -> ?ticks:float -> ?label:string list -> ?scale:float list -> float list list -> Picture.t list (** [stack l] builds a list of pictures from a list [l] of floating-point lists. Each picture represents one radar, and all picture have the same size. Each sublist represents one radar datas, and all sublists must have the same length. For most optional arguments, see function [stack] above. @param fill Fill the radar with its color. *) end (** Build a legend for diagrams. *) module Legend : sig val legend : ?ensstroke:Color.t -> ?colstroke:Color.t -> ?fill:Color.t -> (Color.t * string) list -> Picture.t end (** {2 Metapost generation} *) (* Misc does not appear in the documentation *) (**/**) module Misc : sig val write_to_file : string -> (out_channel -> 'a) -> unit val write_to_formatted_file : string -> (Format.formatter -> 'a) -> unit val print_option : string -> (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a option -> unit val print_list : ('a -> unit -> 'b) -> ('a -> 'c -> unit) -> 'a -> 'c list -> unit val space : Format.formatter -> unit -> unit val comma : Format.formatter -> unit -> unit val fold_from_to : ('a -> int -> 'a) -> 'a -> int -> int -> 'a (** [fold_from_to f acc i j] is equivalent to [List.fold_left f acc [i; i +1; .. j] ], where i <= j *) val call_cmd : ?inv:bool -> ?outv:bool -> ?verbose:bool -> string -> int * string end (**/**) (** Functions to generate Metapost files *) module Metapost : sig val set_filename_prefix : string -> unit (** Add to the filename given to the emit function this prefix. This function is here just for convenience *) val generate_mp : string -> ?prelude:string -> ?eps:bool -> (int * Command.t) list -> unit val generate : string -> ?prelude:string -> ?pdf:bool -> ?eps:bool -> ?verbose:bool -> ?clean:bool -> (int * Command.t) list -> unit val emit : string -> Command.t -> unit val dump : ?prelude:string -> ?pdf:bool -> ?eps:bool -> ?verbose:bool -> ?clean:bool -> string -> unit (** [dump ?prelude ?pdf f] builds a Metapost file [f.mp] for all figures, then runs Metapost on it, and renames figure files according to the names specified to [emit]. The file suffix is [.mps] if [pdf] is set, and [.1] otherwise. *) val dump_mp : ?prelude:string -> string -> unit val dump_png : ?prelude:string -> ?verbose:bool -> ?clean:bool -> string -> unit val read_prelude_from_tex_file : string -> string (** read the prelude from a tex file, until the end of file or the text "\begin\{document\}" if it is outside a comment *) val dump_tex : ?prelude:string -> string -> unit (** [dump_tex ?prelude f] builds a LaTeX file [f.tex] for all the figures, using LaTeX prelude [prelude] if given. *) val slideshow : Command.t list -> int -> (int * Command.t) list (** takes a list of figures and returns a list of figures of exactly the same size (the size of the biggest figure). Shared objects are hopefully placed at the same absolute location across figures. The resulting figures are numbered with consecutive increasing integers, starting with the given value. *) val emit_slideshow : string -> Command.t list -> unit (** emit the list of figures as a slideshow, using the [slideshow] function.*) val dumpable : unit -> unit val depend : string -> unit end (** Helper functions to generate test TeX files *) module Generate : sig val generate_tex : ?pdf:bool -> string -> string -> string -> (int * 'a) list -> unit val generate_tex_cairo : string -> string -> string -> string -> (int * 'a) list -> unit end (** Compute concrete values of numerics, points and paths; not always available *) module Concrete : sig val supported : bool (** The module of concrete points *) module CPoint : sig IFDEF CAIRO THEN type t = Cairo.point = { x : float; y : float } ELSE type t = { x : float; y : float } END val add : t -> t -> t val sub : t -> t -> t val opp : t -> t val mult : float -> t -> t val div : t -> float -> t module Infix : sig val (+/) : t -> t -> t (** alias for {!Concrete.CPoint.add} *) val (-/) : t -> t -> t (** alias for {!Concrete.CPoint.sub} *) val ( */) : float -> t -> t (** alias for {!Concrete.CPoint.mult} *) val ( //) : t -> float -> t (** alias for {!Concrete.CPoint.div} *) end val print : Format.formatter -> t -> unit end (** Concrete Paths *) module CPath : sig (* A path is a succession of splines *) type t type abscissa = float val length : t -> float val is_closed : t -> bool val is_a_point : t -> CPoint.t option val intersection : t -> t -> (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 one_intersection : t -> t -> (abscissa * abscissa) (** one_intersection p1 p2 return one of the intersections between p1 and p2 or raise Not_found if none exists*) val reverse : t -> t (** reverse p return the path p reversed *) val iter : (CPoint.t -> CPoint.t -> CPoint.t -> CPoint.t -> unit) -> t -> unit (** iter on all the splines of a path: iter f p applies f successively to the splines of p with : - the start point of the spline as first argument - the control point of the start point as second argument - the control point of the end point as third argument - the end point as fourth argument *) val fold_left : ('a -> CPoint.t -> CPoint.t -> CPoint.t -> CPoint.t -> 'a) -> 'a -> t -> 'a (** fold on all the splines of a path *) val cut_before : t -> t -> t val cut_after : t -> t -> t (** remove the part of a path before the first intersection or after the last*) val split : t -> abscissa -> t * t val subpath : t -> abscissa -> abscissa -> t val direction_of_abscissa : t -> abscissa -> CPoint.t val point_of_abscissa : t -> abscissa -> CPoint.t val bounding_box : t -> CPoint.t * CPoint.t val dist_min_point : t -> CPoint.t -> float * abscissa val dist_min_path : t -> t -> float * (abscissa * abscissa) val print : Format.formatter -> t -> unit end module CTransform : sig IFDEF CAIRO THEN type t = Cairo.matrix = { xx : float; yx : float ; xy : float; yy : float; x0 : float; y0 : float; } ELSE type t = { xx : float; yx : float; xy : float; yy : float; x0 : float; y0 : float; } END end (** {2 Compute the concrete value} *) val float_of_num : Num.t -> float val compute_nums : unit -> (Num.t -> unit) * (unit -> unit) (** The value of a num in bp *) val cpoint_of_point : Point.t -> CPoint.t val cpath_of_path : Path.t -> CPath.t val ctransform_of_transform : Transform.t -> CTransform.t (** {2 Compute the baselines of a tex} *) val baselines : string -> float list (** {2 Simple functions for the opposite operations} *) val num_of_float : float -> Num.t (** exactly Num.bp *) val point_of_cpoint : CPoint.t -> Point.t val path_of_cpath : CPath.t -> Path.t val transform_of_ctransform : CTransform.t -> Transform.t (** {2 Some options (the mlpost tool takes care of them)} *) val set_verbosity : bool -> unit val set_prelude : string -> unit (** set_prelude filename uses the prelude of the file filename for compilation of the tex snippets *) val set_prelude2 : string option -> unit (** set_prelude2 prelude uses this prelude for compilation of the tex snippets *) val set_t1disasm : string option -> unit (** Deprecated in a next release *) end (** Use the Cairo backend to draw your figures; not always available *) module Cairost : sig val supported : bool val emit_pdf : ?msg_error:float -> string -> Command.t -> unit (* The optional argument set the replacement the figure by the text of the exception in a paragraph of width msg_error *) val emit_ps : string -> Command.t -> unit val emit_png : string -> Command.t -> unit val emit_svg : string -> Command.t -> unit val emit_pdfs : string -> Command.t list -> unit (** One figure by page *) val dump_pdf : unit -> unit val dump_ps : unit -> unit val dump_png : unit -> unit val dump_svg : unit -> unit val dump_pdfs : string -> unit (** Use the figures recorded by the function emit of metapost *) val generate_pdfs : string -> (int * Command.t) list -> unit IFDEF CAIRO THEN type cairo_t = Cairo.t ELSE type cairo_t END val emit_cairo : cairo_t -> float * float -> Command.t -> unit end (**/**) module Metapost_tool : sig val read_prelude_from_tex_file : string -> string end (**/**) mlpost-0.8.1/point.ml0000644000443600002640000001165211365367177013711 0ustar kanigdemons(**************************************************************************) (* *) (* 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 Infix type corner = Types.corner type t = Types.point (* angle in degrees *) let dir f = let angle = Num.deg2rad f in mkPTPair (mkF (cos angle)) (mkF (sin angle)) let up = mkPTPair zero one let down = mkPTPair zero minus_one let left = mkPTPair minus_one zero let right = mkPTPair one zero let simple_transform t str = mkPTTransformed t str let xpart p = match p.Hashcons.node with | PTPair (a,b) -> a | _ -> mkNXPart p let ypart p = match p.Hashcons.node with | PTPair (a,b) -> b | _ -> mkNYPart p (* insert more sophisticated simplifications *) let rec add p1 p2 = match p1.Hashcons.node,p2.Hashcons.node with | PTPair (a1,b1), PTPair (a2,b2) -> mkPTPair (addn a1 a2) (addn b1 b2) | PTAdd (p1',p2'), _ -> add p1' (add p2' p2) | PTSub (p1',p2'), _ -> add p1' (sub p2 p2') | _, _ -> mkPTAdd p1 p2 and mult f p = (* if Num.is_zero f then PTPair (F 0.,F 0.) else *) match p.Hashcons.node with | PTPair (a,b) -> mkPTPair (multn f a) (multn f b) | PTMult (f', p) -> mult (multn f f') p | PTAdd (p1,p2) -> add (mult f p1) (mult f p2) | PTSub (p1,p2) -> sub (mult f p1) (mult f p2) | PTRotated (f', p) -> mkPTRotated f' (mult f p) | _ -> mkPTMult f p and sub p1 p2 = match p1.Hashcons.node,p2.Hashcons.node with | PTPair (a1,b1), PTPair (a2,b2) -> mkPTPair (subn a1 a2) (subn b1 b2) | PTAdd (p1',p2'), _ -> add p1' (sub p2' p2) | PTSub (p1',p2'), _ -> sub p1' (add p2' p2) | _, _ -> mkPTSub p1 p2 let shift = add let scale = mult let segment f p1 p2 = add (mult (mkF (1.-.f)) p1) (mult (mkF f) p2) let rec rotate f p = match p.Hashcons.node with | PTPair (a,b) -> let angle = Num.deg2rad f in mkPTPair ((mkF (cos angle) */ a) -/ (mkF (sin angle) */ b)) ((mkF (sin angle) */ a) +/ (mkF (cos angle) */ b)) | PTAdd (p1, p2) -> add (rotate f p1) (rotate f p2) | PTSub (p1, p2) -> sub (rotate f p1) (rotate f p2) | PTRotated (f', p) -> mkPTRotated (f+.f') p | PTMult (f', p) -> mkPTMult f' (rotate f p) | _ -> mkPTRotated f p (* rotate p2 around p1 *) let rotate_around p1 f p2 = add p1 (rotate f (sub p2 p1)) let xscale f p = match p.Hashcons.node with | PTPair (a,b) -> mkPTPair (mkNMult f a) b | _ -> simple_transform p (mkTRXscaled f) let yscale f p = match p.Hashcons.node with | PTPair (a,b) -> mkPTPair a (mkNMult f b) | _ -> simple_transform p (mkTRYscaled f) let transform tr p = List.fold_left (fun acc str -> match str.Hashcons.node with | TRScaled f -> mult f acc | TRShifted p -> add acc p | TRRotated f -> rotate f acc | TRXscaled f -> xscale f acc | TRYscaled f -> yscale f acc | TRRotateAround (p,f) -> rotate_around p f acc | _ -> simple_transform acc str ) p tr (* From simplePoint *) let pmap f (a,b) = (f a, f b) let pt (a,b) = mkPTPair a b let p ?(scale=Num.bp) pr = pt (pmap scale pr) let length p = gmean (xpart p) (ypart p) let origin = p (0.,0.) let ptlist ?scale l = List.map (p ?scale) l (* construct a point with the right measure *) let bpp, inp, cmp, mmp, ptp = p ~scale:Num.bp, p ~scale:Num.inch, p ~scale:Num.cm, p ~scale:Num.mm, p ~scale:Num.pt (* construct a list of points with the right measure *) let map_bp, map_in, map_cm, map_mm, map_pt = ptlist ~scale:Num.bp, ptlist ~scale:Num.inch, ptlist ~scale:Num.cm, ptlist ~scale:Num.mm, ptlist ~scale:Num.pt let draw ?brush ?color ?pen 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 (mkPAofMPA (mkMPAKnot (mkKnot mkNoDir t mkNoDir))) (mkBrushOpt brush color pen None)) let normalize p = let l = (length p) in scale (if_null l zero (Num.divn Num.one l)) p mlpost-0.8.1/compile.ml0000644000443600002640000003174511365367177014215 0ustar kanigdemons(**************************************************************************) (* *) (* 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 num_names = D.NM.create 257 let point_names = D.PtM.create 257 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' = function | F f -> C.F f, nop | NXPart p -> let p,c = point p in C.NXPart p, c | NYPart p -> let p,c = point p in C.NYPart p, c | NAdd(n1,n2) -> let n1,c1 = num n1 in let n2,c2 = num n2 in C.NAdd (n1,n2), c1 ++ c2 | NSub(n1,n2) -> let n1,c1 = num n1 in let n2,c2 = num n2 in C.NSub (n1,n2), c1 ++ c2 | NMult (n1,n2) -> let n1,c1 = num n1 in let n2,c2 = num n2 in C.NMult (n1,n2), c1 ++ c2 | NDiv (n1,n2) -> let n1,c1 = num n1 in let n2,c2 = num n2 in C.NDiv (n1,n2), c1 ++ c2 | NMax (n1,n2) -> let n1,c1 = num n1 in let n2,c2 = num n2 in C.NMax (n1,n2), c1 ++ c2 | NMin (n1,n2) -> let n1,c1 = num n1 in let n2,c2 = num n2 in C.NMin (n1,n2), c1 ++ c2 | NGMean (n1,n2) -> let n1,c1 = num n1 in let n2,c2 = num n2 in C.NGMean (n1,n2), c1 ++ c2 | NLength p -> let p,c = path p in C.NLength p, c | NIfnullthenelse (n,n1,n2) -> let n,c = num n in let n1,c1 = num n1 in let n2,c2 = num n2 in C.NIfnullthenelse (n,n1,n2), c ++ c1 ++ c2 and num n = match n.node with | F f -> C.F f, nop | _ -> let cnt = try !(D.NM.find D.num_map n) with Not_found -> assert false in if cnt >= 2 then num_save n else num' n.node and num_save n = try let x = D.NM.find num_names n in C.NName x, nop with Not_found -> let n', code = num' n.node in let x = Name.num () in let () = D.NM.add num_names n x in C.NName x, code ++ C.CDeclNum (x,n') and point' = function | PTPair (f1,f2) -> let f1, c1 = num f1 in let f2,c2 = num f2 in C.PTPair (f1,f2), c1 ++ c2 | PTPointOf (f,p) -> let f, c = num f in let p, code = path p in C.PTPointOf (f, p), c ++ code | PTDirectionOf (f,p) -> let f, c = num f in let p, code = path p in C.PTDirectionOf (f, p), c ++ code | PTAdd (p1,p2) -> let p1,c1 = point p1 in let p2,c2 = point p2 in C.PTAdd (p1,p2), c1 ++ c2 | PTSub (p1,p2) -> let p1,c1 = point p1 in let p2,c2 = point p2 in C.PTSub (p1,p2), c1 ++ c2 | PTMult (f,p) -> let f, c1 = num f in let p1,c2 = point p in C.PTMult (f,p1), c1 ++ c2 | PTRotated (f,p) -> let p1,c1 = point p in C.PTRotated (f,p1), c1 | PTPicCorner (pic, corner) -> let pic, code = commandpic_pic pic in C.PTPicCorner (pic, corner) , code | PTTransformed (p,tr) -> let p, c1 = point p in let tr, c2 = transform tr in C.PTTransformed (p,tr), c1 ++ c2 and point p = match p.node with | PTPair _ -> point' p.node | _ -> let cnt = try !(D.PtM.find D.point_map p) with Not_found -> assert false in if cnt >= 2 then point_save p else point' p.node and point_save p = try let x = D.PtM.find point_names p in C.PTName x, nop with Not_found -> let p', code = point' p.node in let x = Name.point () in let () = D.PtM.add point_names p x in C.PTName x, code ++ C.CDeclPoint (x,p') 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 = match t.Hashcons.node with | TRRotated f -> C.TRRotated f, nop | TRScaled f -> let f,c = num f in C.TRScaled f, c | TRSlanted f -> let f,c = num f in C.TRSlanted f, c | TRXscaled f -> let f,c = num f in C.TRXscaled f, c | TRYscaled f -> let f,c = num f in C.TRYscaled f, c | TRShifted p -> let p, code = point p in C.TRShifted p, code | TRZscaled p -> let p, code = point p in C.TRZscaled p, code | TRReflect (p1,p2) -> let p1, c1 = point p1 in let p2, c2 = point p2 in C.TRReflect (p1,p2), c1 ++ c2 | TRRotateAround (p,f) -> let p, code = point p in C.TRRotateAround (p,f), code | TRMatrix p -> let nx0,nc0 = num p.x0 in let ny0,nc1 = num p.y0 in let nxx,nc2 = num p.xx in let nxy,nc3 = num p.xy in let nyx,nc4 = num p.yx in let nyy,nc5 = num p.yy in let tname = Name.transform () in C.TRName tname, nc0 ++ nc1 ++ nc2 ++ nc3 ++ nc4 ++ nc5 ++ C.CDefTrans (tname,{ C.x0 = nx0; y0 = ny0; xx = nxx; xy = nxy; yx = nyx; yy = nyy}) 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.NM.clear D.num_map; D.NM.clear num_names; D.PtM.clear point_names; D.PtM.clear D.point_map; 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.1/mlpost_desc_options.ml0000644000443600002640000000536411365367177016652 0ustar kanigdemons(**************************************************************************) (* *) (* 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 Arg let pdf = ref true let latex_file = ref None let set_latex_file f = if not (Sys.file_exists f) then begin eprintf "mlpost: %s: no such file@." f; exit 1 end; latex_file := Some f let xpdf = ref false let eps = ref false let verbose = ref false let cairo = ref false let t1disasm = ref None let depend = ref false let dumpable = ref false let dont_clean = ref false let mp = ref false let png = ref false let svg = ref false let filename_prefix = ref "" (* notuple please or change Tool.wrap_options *) let spec = (["-pdf", Set pdf, " Generate .mps files (default)"; "-mp", Set mp, " Generate .mp files"; "-png", Set png, " Generate .png files"; "-ps", Clear pdf, " Generate .1 files"; "-svg", Set svg, " Generate .svg files (only with cairo)"; "-latex", String set_latex_file, " Scan the LaTeX prelude"; "-eps", Set eps, " Generate encapsulated postscript files"; "-xpdf", Set xpdf, " wysiwyg mode using xpdf remote server"; "-v", Set verbose, " be a bit more verbose"; "-depend", Set depend, " output dependency lines in a format suitable for the make(1) utility"; "-dumpable", Set dumpable, " output one name of dumpable file by line"; "-dont-clean", Set dont_clean, " Don't remove intermediate files"; "-cairo" , Set cairo, " Use the cairo backend instead of metapost"; "-prefix", String ((:=) filename_prefix), "Add to all the filename this prefix"; "-t1disasm" , String (fun s -> t1disasm := Some s), " Set the program used to decrypt PostScript Type 1 font, \ only with cairo (default built-in one)"]) mlpost-0.8.1/metapost.ml0000644000443600002640000001750311365367177014415 0ustar kanigdemons(**************************************************************************) (* *) (* 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 let print i fmt c = (* resetting is actually not needed; variables other than x,y are not local to figures *) (* Compile.reset (); *) let () = Duplicate.commandpic c in let c = Compile.commandpic_cmd c in fprintf fmt "@[beginfig(%d)@\n @[%a@] endfig;@]@." i MPprint.command c let print_prelude ?(eps=false) s fmt () = fprintf fmt "input mp-tool ; %% some initializations and auxiliary macros input mp-spec ; %% macros that support special features %%redefinition def doexternalfigure (expr filename) text transformation = begingroup ; save p, t ; picture p ; transform t ; p := nullpicture ; t := identity transformation ; flush_special(10, 9, dddecimal (xxpart t, yxpart t, xypart t) & \" \" & dddecimal (yypart t, xpart t, ypart t) & \" \" & filename) ; addto p contour unitsquare transformed t ; setbounds p to unitsquare transformed t ; _color_counter_ := _color_counter_ + 1 ; draw p withcolor (_special_signal_/_special_div_,\ _color_counter_/_special_div_,_special_counter_/_special_div_) ; endgroup ; enddef ; vardef reset_extra_specials = enddef ; @\n"; if eps then fprintf fmt "prologues := 2;@\n" else (fprintf fmt "prologues := 0;@\n"; fprintf fmt "mpprocset := 0;@\n"); fprintf fmt "verbatimtex@\n"; fprintf fmt "%%&latex@\n"; fprintf fmt "%s" s; fprintf fmt "\\begin{document}@\n"; fprintf fmt "etex@\n" (* fprintf fmt "input boxes;@\n" *) let defaultprelude = "\\documentclass{article}\n\\usepackage[T1]{fontenc}\n" let generate_mp fn ?(prelude=defaultprelude) ?eps l = Misc.write_to_formatted_file fn (fun fmt -> print_prelude ?eps prelude fmt (); List.iter (fun (i,f) -> print i fmt f) l; fprintf fmt "end@.") (* batch processing *) let figuren = ref 0 let figures = Queue.create () let filename_prefix = ref "" let set_filename_prefix = (:=) filename_prefix let emit s f = incr figuren; Queue.add (!figuren, !filename_prefix^s, f) figures let read_prelude_from_tex_file = Metapost_tool.read_prelude_from_tex_file let dump_tex ?prelude f = let c = open_out (f ^ ".tex") in let fmt = formatter_of_out_channel c in begin match prelude with | None -> fprintf fmt "\\documentclass[a4paper]{article}"; fprintf fmt "\\usepackage{graphicx}" | Some s -> fprintf fmt "%s@\n" s end; fprintf fmt "\\begin{document}@\n"; fprintf fmt "\\begin{center}@\n"; Queue.iter (fun (_,s,_) -> fprintf fmt "\\hrulefill\\verb!%s!\\hrulefill\\\\[1em]@\n" s; (* fprintf fmt "\\framebox{\\includegraphics[width=\\textwidth]\ {%s.mps}}\\\\[1em]@\n" s; *) (* fprintf fmt "\\framebox{\\includegraphics{%s.mps}}\\\\@\n" s; *) fprintf fmt "\\includegraphics{%s.mps}\\\\@\n" s; fprintf fmt "\\hrulefill\\\\@\n@\n\\medskip@\n";) figures; fprintf fmt "\\end{center}@\n"; fprintf fmt "\\end{document}@."; close_out c let print_latex_error s = if Sys.file_exists "mpxerr.tex" then begin Printf.printf "############################################################\n"; Printf.printf "LaTeX has found an error in your file. Here is its output:\n"; ignore (Misc.call_cmd ~outv:true "latex -interaction=nonstopmode mpxerr.tex") end else Printf.printf "%s\n" s let generate_aux rename bn ?prelude ?(pdf=false) ?eps ?(verbose=false) ?(clean=true) figl = if figl <> [] then let do_ workdir tmpdir = (* a chdir has been done to tmpdir *) let f = bn ^ ".mp" in generate_mp f ?prelude ?eps figl; let s,outp = Misc.call_cmd ~verbose (sprintf "mpost -interaction=\"nonstopmode\" %s" f) in if s <> 0 then print_latex_error outp else rename workdir tmpdir; s in let s = Metapost_tool.tempdir ~clean "mlpost" "mpost" do_ in if s <> 0 then exit 1 let generate bn ?prelude ?(pdf=false) ?eps ?verbose ?clean figl = let basename = Filename.basename bn in let rename workdir tmpdir = let suf = if pdf then ".mps" else ".1" in let sep = if pdf then "-" else "." in List.iter (fun (i,_) -> let si = string_of_int i in let from = Filename.concat tmpdir (basename ^ "." ^ si) in let to_ = Filename.concat workdir (bn ^ sep ^ si ^ suf) in Metapost_tool.file_move from to_) figl in generate_aux rename basename ?prelude ~pdf ?eps ?verbose ?clean figl let dump ?prelude ?(pdf=false) ?eps ?(verbose=false) ?clean bn = let figl = Queue.fold (fun l (i,_,f) -> (i,f) :: l) [] figures in let bn = Filename.basename bn in let rename workdir tmpdir = let suf = if pdf then ".mps" else ".1" in Queue.iter (fun (i,s,_) -> let e = s ^ suf in let from = Filename.concat tmpdir (bn ^ "." ^ string_of_int i) in let to_ = Filename.concat workdir e in if verbose then Printf.printf "saving result in %s\n" e; Metapost_tool.file_move from to_) figures in generate_aux rename bn ?prelude ~pdf ?eps ~verbose ?clean figl let dump_mp ?prelude bn = let figl = Queue.fold (fun l (i,_,f) -> (i,f) :: l) [] figures in let f = bn ^ ".mp" in generate_mp f ?prelude figl (** with mptopdf *) let dump_png ?prelude ?(verbose=false) ?(clean=true) bn = dump_mp ?prelude bn; let s,outp = Misc.call_cmd ~verbose (sprintf "mptopdf %s.mp" bn) in if s <> 0 then print_latex_error outp; if clean then ignore (Misc.call_cmd ~verbose (Printf.sprintf "rm -f mpxerr.log mpxerr.tex mpxerr.aux mpxerr.dvi %s.mp %s.mpx %s.log" bn bn bn)); if s <> 0 then exit 1; Queue.iter (fun (i,s,_) -> let s,outp = Misc.call_cmd ~verbose (sprintf "convert -density 600x600 \"%s-%i.pdf\" \"%s.png\"" bn i s) in if clean then ignore (Misc.call_cmd ~verbose (Printf.sprintf "rm -f %s-%i.pdf" bn i)); if s <> 0 then ( ignore (Misc.call_cmd ~verbose (Printf.sprintf "rm -f %s-*.pdf" bn));exit 1) ) figures let slideshow l k = let l = List.map Picture.make l in let l' = Command.seq (List.map (fun p -> Command.draw ~color:Color.white (Picture.bbox p)) l) in let x = ref (k-1) in List.map (fun p -> incr x; !x, Command.seq [l'; Command.draw_pic p]) l let emit_slideshow s l = let l = slideshow l 0 in List.iter (fun (i,fig) -> emit (s^(string_of_int i)) fig) l let emited () = Queue.fold (fun l (i,n,f) -> (i,n,f) :: l) [] figures let dumpable () = Queue.iter (fun (_,s,_) -> Printf.printf "%s\n" s) figures let depend myname = Queue.iter (fun (_,s,_) -> Printf.printf "%s.fmlpost " s) figures; Printf.printf " : %s.cmlpost\n" myname mlpost-0.8.1/othergraphs.ml0000644000443600002640000001660611365367177015112 0ustar kanigdemons(**************************************************************************) (* *) (* 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 Box open Command open Point open Path module Co = Color module P = Pen module T = Transform module N = Num module H = Helpers let a = 0., 0. let b = 1., 0. let c = 0., 1. let l = [a ; b ; c] let d1 = 1, draw (path ~style:jLine ~scale:N.cm l) let d2 = 2, draw (path ~style:jLine ~scale:N.cm ~cycle:jLine l) let d4 = let pen = Pen.scale (bp 4.) Pen.circle in 4, draw ~pen (path ~scale:N.cm [a]) let d5 = 5, let pen = Pen.scale (bp 4.) P.circle in seq [ draw (path ~style:jLine ~scale:N.cm ~cycle:jLine l); seq (List.map (fun point -> draw ~pen (path ~scale:N.cm [point])) l) ] let d7 = 7, let a , b, c = cmp a, cmp b, cmp c in seq [draw (path ~style:jLine ~scale:N.cm ~cycle:jLine l) ; draw (pathp [ segment 0.5 a b ; c]) ; draw (pathp [ segment 0.5 b c ; a]) ; draw (pathp [ segment 0.5 c a ; b]) ; ] let d12 = 12, let pen = Pen.scale two Pen.circle in let cl = List.map Color.gray [0.8;0.6;0.4] in seq (List.map2 (fun (a,b) color -> draw ~pen ~color (path ~style:jLine ~scale:N.cm [a;b])) [a,b;b,c;c,a] cl) let triangle = path ~scale:N.cm ~style:jLine ~cycle:jLine [(0.,0.);(1.,0.);(0.,1.)] let d20 = 20, fill ~color:(Color.gray 0.8) triangle let d21 = 21, seq [fill ~color:(Color.gray 0.8) triangle; draw triangle] let d22 = let pen = Pen.scale two Pen.circle in 22, seq [fill ~color:(Color.gray 0.8) triangle; draw ~pen triangle] let d23 = let pen = Pen.scale two Pen.circle in 23, seq [draw ~pen triangle; fill ~color:(Color.gray 0.8) triangle] let d60 = let a = p ~scale:N.cm (0.,0.) in let b = p ~scale:N.cm ((-0.5), 1.) in let c = p ~scale:N.cm (2., 1.5) in let d = p ~scale:N.cm (1.5, 0.) in let pen = Pen.scale two Pen.circle in seq [ draw ~pen (jointpathp [a;d] [jControls b c]); draw ~color:(Co.gray 0.8) (pathp ~style:jLine [b;c]); H.draw_simple_arrow a b; H.draw_simple_arrow d c; ] let d111 = let a = Path.shift (p ~scale:N.cm (0.5, 0.)) (Path.scale (N.cm 2.) fullcircle) in let t = [T.rotated 120.] in let b = transform t a in let c = transform t b in seq (List.map (fun (color, p) -> fill ~color p) [ Co.red, a ; Co.green, b; Co.blue, c; Co.yellow, build_cycle [a;b]; Co.cyan, build_cycle [b;c]; Co.magenta, build_cycle [c;a]; Co.white, build_cycle [a;b;c] ] @ List.map draw [a;b;c]) let deuxpi = 2.*.3.14159 let d130 = let sq = path ~style:jLine ~scale:N.cm ~cycle:jLine [(0.,0.);(2.,0.);(2.,2.);(0.,2.)] in (** on peut pas utiliser la resolution de MetaPost donc on construit la transform à la main.. :-/ *) let ratio = sqrt (3.28 /. 4.) in let angle = atan (0.2 /. 1.8) *. 360. /. deuxpi in let v = pt (Num.cm 0.2, Num.cm 0.) in let t = [T.rotated angle; T.scaled (bp ratio); T.shifted v] in let rec apply acc = function 0 -> acc | n -> apply (transform t acc) (n-1) in let cmd i = let p = apply sq (2*i) in seq [fill ~color:(Color.gray 0.8) p; fill ~color:Color.white (transform t p)] in 130, iter 0 49 cmd let d140 = let cmd i = let s = 1. -. ((float_of_int i) *. 0.01) in fill ~color:(Color.gray s) (Path.scale (Num.cm (2.*.s)) fullcircle) in 140, seq [iter 0 99 cmd; draw ~pen:(Pen.scale two Pen.circle) (Path.scale (Num.cm 2.) fullcircle)] let d149 = let step = deuxpi /. 720. in let couleur x = let dblx = 2.*.x in if x > 0.5 then Color.rgb (dblx-.1.) 0. (2.-.dblx) else Color.rgb (1.-.dblx) 0. dblx in let pt angle = (2.*.sin(2.*.angle), 2.*.cos(3.*.angle)) in let pen = Pen.scale two Pen.circle in let cmd i = let angle = step *. (float_of_int i) in draw ~color:(couleur (angle /. deuxpi)) ~pen (path ~scale:N.cm [pt angle]) in 149,Command.iter 0 719 cmd let d195 = let n = 8 and u x = 5.*. (float_of_int x) in let un = u n and u1 = u 1 and udemi = (u 1) /. 5. in let color = Color.gray 0.8 in let t i j = T.shifted (pt (Num.mm (u i), Num.mm (u j))) in let row i = let col j = if (i+j) mod 2 = 1 then let strip k = let kf = (float_of_int k) *. udemi in let umk = u1 -. kf in let udp = kf +. udemi and udm = umk -. udemi in let l = if k mod 2 = 1 then [(kf,0.); (u1,umk); (u1,udm); (udp,0.)] else [(0.,kf); (umk,u1); (udm,u1); (0.,udp)] in fill ~color (transform [t i j] (path ~style:jLine ~scale:N.mm ~cycle:jLine l)) in Command.iter 0 4 strip else Command.nop in Command.iter 0 (n-1) col in let grid i = let ui = u i in seq [draw (path ~style:jLine ~scale:N.mm [(0.,ui); (un, ui)]); draw (path ~style:jLine ~scale:N.mm [(ui,0.); (ui, un)])] in 195, seq [Command.iter 0 (n-1) row; Command.iter 0 (n) grid] let d267 = let tex = tex ~stroke:(Some Color.black) in let rose = Color.rgb 1. 0.5 0.5 in let a = tex ~fill:rose ~style:RoundBox "D\\'ebut" in let b = Box.shift (cmp (2., 0.)) (tex ~fill:rose ~style:RoundBox "Fin") in let path angle a b = cut_after (bpath b) (cut_before (bpath a) (jointpathk [knotp ~r:(vec (dir angle)) (Box.ctr a); knotp ~r:(vec (dir (-. angle))) (Box.ctr b)] [jCurve])) in seq [Box.draw a; Box.draw b; Arrow.simple (path 45. a b); Arrow.simple (path (-135.) b a)] let min = -1. let max = 1. 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 [p;draw b;fill ~color:Color.white b] let figs = [ d1; d2; d4; d5; d7; d12; d20; d21; d22; d23; 60, d60; 111, d111; d130; d140; d149; d195; 267,d267 ] let mpostfile = "othergraphs" let cairostfile = "testother_cairo" let texfile = "othergraphs.tex" (* let _ = Metapost.generate_mp mpostfile figs; Generate.generate_tex texfile "othergraphs/mpost" "othergraph" figs *) let _ = Sys.chdir "test"; if Cairost.supported then begin Metapost.generate mpostfile ~pdf:true figs; Cairost.generate_pdfs cairostfile figs; Generate.generate_tex_cairo texfile "othergraphs/mpost" "othergraphs" "testother_cairo" figs; end else begin Metapost.generate mpostfile ~pdf:true figs; Generate.generate_tex ~pdf:true texfile "othergraphs/mpost" "othergraphs" figs; end mlpost-0.8.1/metapost_tool.ml0000644000443600002640000000443411365367177015451 0ustar kanigdemons(**************************************************************************) (* *) (* 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 read_prelude_from_tex_file file = let c = open_in file in let s = Scan_prelude.scan (Lexing.from_channel c) in close_in c; s (* f is called with f currdir tempdir *) let tempdir ?(clean=true) prefix suffix f = let rec create_dir () = try let dirname = Filename.concat Filename.temp_dir_name (Printf.sprintf "%s%i%s" prefix (Random.int 10000) suffix) in Unix.mkdir dirname 0o700; dirname with | Unix.Unix_error (Unix.EEXIST, _, _) -> create_dir () in let dirname = create_dir () in let workdir_bak = Sys.getcwd () in Sys.chdir dirname; let res = f workdir_bak dirname in Sys.chdir workdir_bak; if clean then begin Array.iter (fun x -> Sys.remove (Filename.concat dirname x)) (Sys.readdir dirname); Unix.rmdir dirname; end; res let file_copy src dest = let cin = open_in src and cout = open_out dest and buff = String.make 1024 ' ' and n = ref 0 in while n := input cin buff 0 1024; !n <> 0 do output cout buff 0 !n done; close_in cin; close_out cout let file_move src dest = try Unix.rename src dest with Unix.Unix_error (Unix.EXDEV,_,_) -> file_copy src dest mlpost-0.8.1/print.ml0000644000443600002640000001514011365367177013710 0ustar kanigdemons(**************************************************************************) (* *) (* 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. *) (* *) (**************************************************************************) (* print an mlpost AST for debugging *) open Concrete_types open Types open Format let option_print pr fmt = function | None -> () | Some x -> pr fmt x let position fmt p = match pos_reduce p with | `Center -> fprintf fmt "" | `West -> fprintf fmt ".lft" | `East -> fprintf fmt ".rt" | `North -> fprintf fmt ".top" | `South -> fprintf fmt ".bot" | `Northwest -> fprintf fmt ".ulft" | `Northeast -> fprintf fmt ".urt" | `Southwest -> fprintf fmt ".llft" | `Southeast -> fprintf fmt ".lrt" let rec num fmt n = match n.Hashcons.node with | F f -> fprintf fmt "%f" f | NXPart p -> fprintf fmt "xpart(%a)" point p | NYPart p -> fprintf fmt "ypart(%a)" point p | NAdd(n1,n2) -> fprintf fmt "(%a + %a)" num n1 num n2 | NSub(n1,n2) -> fprintf fmt "(%a - %a)" num n1 num n2 | NMult(n1,n2) -> fprintf fmt "(%a * %a)" num n1 num n2 | NDiv(n1,n2) -> fprintf fmt "(%a / %a)" num n1 num n2 | NMax(n1,n2) -> fprintf fmt "max(%a,%a)" num n1 num n2 | NMin(n1,n2) -> fprintf fmt "min(%a,%a)" num n1 num n2 | NLength p -> fprintf fmt "length %a" path p | NGMean (n1,n2) -> fprintf fmt "mean(%a,%a)" num n1 num n2 | NIfnullthenelse (n,n1,n2) -> fprintf fmt "(if %a = 0 then %a else %a)" num n num n1 num n2 and point fmt p = match p.Hashcons.node with | PTPair (n1,n2) -> fprintf fmt "(%a,%a)" num n1 num n2 | PTPicCorner (p,pc) -> fprintf fmt "%a(%a)" position (pc :> position) commandpic p | PTAdd (p1,p2) -> fprintf fmt "(%a + %a)" point p1 point p2 | PTSub (p1,p2) -> fprintf fmt "(%a - %a)" point p1 point p2 | PTMult (n,p) -> fprintf fmt "(%a * %a)" num n point p | _ -> fprintf fmt "somepoint..." and picture fmt p = match p.Hashcons.node with | PITex s -> fprintf fmt "tex(%s)" s | PITransformed (p,tr) -> fprintf fmt "%a transformed %a" commandpic p transform tr | PIClip _ -> () and transform fmt t = match t.Hashcons.node with | TRShifted p -> fprintf fmt "shifted %a" point p | TRYscaled f -> fprintf fmt "yscaled %a" num f | _ -> fprintf fmt "something" and knot fmt k = match k.Hashcons.node with | { knot_in = d1 ; knot_p = p ; knot_out = d2 } -> fprintf fmt "%a%a%a" direction d1 point p direction d2 and direction fmt d = match d.Hashcons.node with | Vec p -> fprintf fmt "{%a}" point p | Curl f -> fprintf fmt "{curl %f}" f | NoDir -> () and metapath fmt p = match p.Hashcons.node with | MPAConcat (k,j,p) -> fprintf fmt "%a%a%a" metapath p joint j knot k | MPAAppend (p1,j,p2) -> fprintf fmt "%a%a%a" metapath p1 joint j metapath p2 | MPAKnot k -> knot fmt k | MPAofPA p -> fprintf fmt "(%a)" path p and path fmt p = match p.Hashcons.node with | PAofMPA p -> fprintf fmt "(from_metapath %a)" metapath p | MPACycle (d,j,p) -> fprintf fmt "(cycle of %a with %a)" metapath p joint j | PATransformed (p,tr) -> fprintf fmt "(tr %a by %a)" path p transform tr | PACutAfter (p1,p2) -> fprintf fmt "(cutafter %a by %a)" path p1 path p2 | PACutBefore (p1,p2) -> fprintf fmt "(cutbefore %a by %a)" path p1 path p2 | PABuildCycle pl -> fprintf fmt "(buildcycle %a)" (Misc.print_list Misc.semicolon path) pl | PASub (f1, f2, p) -> fprintf fmt "(sub %a from %a to %a)" path p num f1 num f2 | PABBox p -> fprintf fmt "(bbox %a)" commandpic p | PAUnitSquare -> fprintf fmt "unitsquare" | PAQuarterCircle -> fprintf fmt "quartercircle" | PAHalfCircle -> fprintf fmt "halfcircle" | PAFullCircle -> fprintf fmt "fullcircle" and joint fmt j = match j.Hashcons.node with | JLine -> fprintf fmt "--" | JCurve -> fprintf fmt ".." | JCurveNoInflex -> fprintf fmt "..." | JTension (a,b) -> fprintf fmt "..tension(%f,%f).." a b | JControls (p1,p2) -> fprintf fmt "..%a..%a.." point p1 point p2 and command fmt c = match c.Hashcons.node with | CDraw (p,b) -> let {color = c; pen = pe; dash = d} = b.Hashcons.node in fprintf fmt "draw (%a,%a,%a,%a);" path p option_color c option_pen pe option_dash d | CFill (p,c) -> fprintf fmt "fill (%a,%a);" path p option_color c | CLabel (pic,pos,pt) -> fprintf fmt "label%a(%a,%a)" position pos commandpic pic point pt | CDotLabel (pic,pos,pt) -> fprintf fmt "dotlabel%a(%a,%a)" position pos commandpic pic point pt | CExternalImage (f,spec) -> fprintf fmt "externalimage %s@ " f and color fmt (c:Types.color) = let mode,color = match c with | OPAQUE c -> (None, c) | TRANSPARENT (f,c) -> (Some f, c) in let pmode fmt = function | None -> fprintf fmt "O" | Some f -> fprintf fmt "%f" f in match color with | RGB (r,g,b) -> fprintf fmt "(%f, %f , %f, %a)" r g b pmode mode | CMYK (c,m,y,k) -> fprintf fmt "(%f, %f, %f, %f, %a)" c m y k pmode mode | Gray f -> fprintf fmt "(%f * white, %a)" f pmode mode and commandpic fmt c = match c.Hashcons.node with | Picture p -> picture fmt p | Command c -> command fmt c | Seq l -> Misc.print_list Misc.space commandpic fmt l and pen fmt x = match x.Hashcons.node with | PenCircle -> fprintf fmt "PenCircle" | PenSquare -> assert false | PenFromPath p -> assert false | PenTransformed (p,trl) -> fprintf fmt "(%a,%a)" pen p transform trl and dash fmt x = match x.Hashcons.node with | DEvenly -> fprintf fmt "evenly" | DWithdots -> assert false | DScaled (f,d) -> fprintf fmt "%a scaled %a" dash d num f | DShifted (p,d) -> assert false | DPattern l -> assert false and option_pen fmt = option_print pen fmt and option_color fmt = option_print color fmt and option_dash fmt = option_print dash fmt mlpost-0.8.1/README.txt0000644000443600002640000000535211365367177013724 0ustar kanigdemons************************************************************************** * * * 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.1/version.ml.in0000644000443600002640000000437111365367177014652 0ustar kanigdemons(**************************************************************************) (* *) (* 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. *) (* *) (**************************************************************************) # 16 "version.ml.in" let version = "@PACKAGE_VERSION@" let date = "@TODAY@" let ocamlopt = "@OCAMLOPT@" let ocamlc = "@OCAMLC@" let libdir = "@LIBDIR@" let include_string = "@INCLUDELIBS@" let cairolib = "@CAIROLIB@" let bitstringlib = "@BITSTRINGLIB@" let cairolablgtk2lib = "@CAIROLABLGTK2LIB@" let lablgtk2lib = "@LABLGTK2LIB@" let not_cairo = cairolib = "" let not_bitstring = bitstringlib = "" (* (contrib_name, (include_list,lib_list)) *) (* The second second composante is linked in reversed order (cma,cmxa) *) let append_dir dir suffix = let dir = if Filename.check_suffix dir "/" then Filename.chop_suffix dir "/" else dir in dir^suffix let libraries libdir = [ "dot", ([append_dir libdir "_dot"],["mlpost_dot"]); "lablgtk", ([append_dir libdir "_lablgtk";lablgtk2lib;cairolablgtk2lib], ["lablgtk"; "cairo_lablgtk"; "mlpost_lablgtk"; ]); "cairo", ([cairolib], ["bigarray";"cairo";]); "bitstring", ([bitstringlib], ["bitstring"]); "mlpost", ([libdir], ["mlpost"]); "mlpost_options", ([libdir], [ "mlpost_desc_options";"mlpost_options"]); "unix" , ([],["unix"]) ] mlpost-0.8.1/configure0000755000443600002640000034610311365367177014137 0ustar kanigdemons#! /bin/sh # Guess values for system-dependent variables and create Makefiles. # Generated by GNU Autoconf 2.65 for mlpost 0.8.1. # # # Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001, # 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation, # Inc. # # # This configure script is free software; the Free Software Foundation # gives unlimited permission to copy, distribute and modify it. ## -------------------- ## ## M4sh Initialization. ## ## -------------------- ## # Be more Bourne compatible DUALCASE=1; export DUALCASE # for MKS sh if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then : emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' setopt NO_GLOB_SUBST else case `(set -o) 2>/dev/null` in #( *posix*) : set -o posix ;; #( *) : ;; esac fi as_nl=' ' export as_nl # Printing a long string crashes Solaris 7 /usr/bin/printf. as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo # Prefer a ksh shell builtin over an external printf program on Solaris, # but without wasting forks for bash or zsh. if test -z "$BASH_VERSION$ZSH_VERSION" \ && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='print -r --' as_echo_n='print -rn --' elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='printf %s\n' as_echo_n='printf %s' else if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' as_echo_n='/usr/ucb/echo -n' else as_echo_body='eval expr "X$1" : "X\\(.*\\)"' as_echo_n_body='eval arg=$1; case $arg in #( *"$as_nl"*) expr "X$arg" : "X\\(.*\\)$as_nl"; arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; esac; expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" ' export as_echo_n_body as_echo_n='sh -c $as_echo_n_body as_echo' fi export as_echo_body as_echo='sh -c $as_echo_body as_echo' fi # The user is always right. if test "${PATH_SEPARATOR+set}" != set; then PATH_SEPARATOR=: (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || PATH_SEPARATOR=';' } fi # IFS # We need space, tab and new line, in precisely that order. Quoting is # there to prevent editors from complaining about space-tab. # (If _AS_PATH_WALK were called with IFS unset, it would disable word # splitting by setting IFS to empty value.) IFS=" "" $as_nl" # Find who we are. Look in the path if we contain no directory separator. case $0 in #(( *[\\/]* ) as_myself=$0 ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break done IFS=$as_save_IFS ;; esac # We did not find ourselves, most probably we were run as `sh COMMAND' # in which case we are not to be found in the path. if test "x$as_myself" = x; then as_myself=$0 fi if test ! -f "$as_myself"; then $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 exit 1 fi # Unset variables that we do not need and which cause bugs (e.g. in # pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" # suppresses any "Segmentation fault" message there. '((' could # trigger a bug in pdksh 5.2.14. for as_var in BASH_ENV ENV MAIL MAILPATH do eval test x\${$as_var+set} = xset \ && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : done PS1='$ ' PS2='> ' PS4='+ ' # NLS nuisances. LC_ALL=C export LC_ALL LANGUAGE=C export LANGUAGE # CDPATH. (unset CDPATH) >/dev/null 2>&1 && unset CDPATH if test "x$CONFIG_SHELL" = x; then as_bourne_compatible="if test -n \"\${ZSH_VERSION+set}\" && (emulate sh) >/dev/null 2>&1; then : emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on \${1+\"\$@\"}, which # is contrary to our usage. Disable this feature. alias -g '\${1+\"\$@\"}'='\"\$@\"' setopt NO_GLOB_SUBST else case \`(set -o) 2>/dev/null\` in #( *posix*) : set -o posix ;; #( *) : ;; esac fi " as_required="as_fn_return () { (exit \$1); } as_fn_success () { as_fn_return 0; } as_fn_failure () { as_fn_return 1; } as_fn_ret_success () { return 0; } as_fn_ret_failure () { return 1; } exitcode=0 as_fn_success || { exitcode=1; echo as_fn_success failed.; } as_fn_failure && { exitcode=1; echo as_fn_failure succeeded.; } as_fn_ret_success || { exitcode=1; echo as_fn_ret_success failed.; } as_fn_ret_failure && { exitcode=1; echo as_fn_ret_failure succeeded.; } if ( set x; as_fn_ret_success y && test x = \"\$1\" ); then : else exitcode=1; echo positional parameters were not saved. fi test x\$exitcode = x0 || exit 1" as_suggested=" as_lineno_1=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_1a=\$LINENO as_lineno_2=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_2a=\$LINENO eval 'test \"x\$as_lineno_1'\$as_run'\" != \"x\$as_lineno_2'\$as_run'\" && test \"x\`expr \$as_lineno_1'\$as_run' + 1\`\" = \"x\$as_lineno_2'\$as_run'\"' || exit 1" if (eval "$as_required") 2>/dev/null; then : as_have_required=yes else as_have_required=no fi if test x$as_have_required = xyes && (eval "$as_suggested") 2>/dev/null; then : else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR as_found=false for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. as_found=: case $as_dir in #( /*) for as_base in sh bash ksh sh5; do # Try only shells that exist, to save several forks. as_shell=$as_dir/$as_base if { test -f "$as_shell" || test -f "$as_shell.exe"; } && { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$as_shell"; } 2>/dev/null; then : CONFIG_SHELL=$as_shell as_have_required=yes if { $as_echo "$as_bourne_compatible""$as_suggested" | as_run=a "$as_shell"; } 2>/dev/null; then : break 2 fi fi done;; esac as_found=false done $as_found || { if { test -f "$SHELL" || test -f "$SHELL.exe"; } && { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$SHELL"; } 2>/dev/null; then : CONFIG_SHELL=$SHELL as_have_required=yes fi; } IFS=$as_save_IFS if test "x$CONFIG_SHELL" != x; then : # We cannot yet assume a decent shell, so we have to provide a # neutralization value for shells without unset; and this also # works around shells that cannot unset nonexistent variables. BASH_ENV=/dev/null ENV=/dev/null (unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV export CONFIG_SHELL exec "$CONFIG_SHELL" "$as_myself" ${1+"$@"} fi if test x$as_have_required = xno; then : $as_echo "$0: This script requires a shell more modern than all" $as_echo "$0: the shells that I found on your system." if test x${ZSH_VERSION+set} = xset ; then $as_echo "$0: In particular, zsh $ZSH_VERSION has bugs and should" $as_echo "$0: be upgraded to zsh 4.3.4 or later." else $as_echo "$0: Please tell bug-autoconf@gnu.org about your system, $0: including any error possibly output before this $0: message. Then install a modern shell, or manually run $0: the script under such a shell if you do have one." fi exit 1 fi fi fi SHELL=${CONFIG_SHELL-/bin/sh} export SHELL # Unset more variables known to interfere with behavior of common tools. CLICOLOR_FORCE= GREP_OPTIONS= unset CLICOLOR_FORCE GREP_OPTIONS ## --------------------- ## ## M4sh Shell Functions. ## ## --------------------- ## # as_fn_unset VAR # --------------- # Portably unset VAR. as_fn_unset () { { eval $1=; unset $1;} } as_unset=as_fn_unset # as_fn_set_status STATUS # ----------------------- # Set $? to STATUS, without forking. as_fn_set_status () { return $1 } # as_fn_set_status # as_fn_exit STATUS # ----------------- # Exit the shell with STATUS, even in a "trap 0" or "set -e" context. as_fn_exit () { set +e as_fn_set_status $1 exit $1 } # as_fn_exit # as_fn_mkdir_p # ------------- # Create "$as_dir" as a directory, including parents if necessary. as_fn_mkdir_p () { case $as_dir in #( -*) as_dir=./$as_dir;; esac test -d "$as_dir" || eval $as_mkdir_p || { as_dirs= while :; do case $as_dir in #( *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( *) as_qdir=$as_dir;; esac as_dirs="'$as_qdir' $as_dirs" as_dir=`$as_dirname -- "$as_dir" || $as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_dir" : 'X\(//\)[^/]' \| \ X"$as_dir" : 'X\(//\)$' \| \ X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$as_dir" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` test -d "$as_dir" && break done test -z "$as_dirs" || eval "mkdir $as_dirs" } || test -d "$as_dir" || as_fn_error "cannot create directory $as_dir" } # as_fn_mkdir_p # as_fn_append VAR VALUE # ---------------------- # Append the text in VALUE to the end of the definition contained in VAR. Take # advantage of any shell optimizations that allow amortized linear growth over # repeated appends, instead of the typical quadratic growth present in naive # implementations. if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then : eval 'as_fn_append () { eval $1+=\$2 }' else as_fn_append () { eval $1=\$$1\$2 } fi # as_fn_append # as_fn_arith ARG... # ------------------ # Perform arithmetic evaluation on the ARGs, and store the result in the # global $as_val. Take advantage of shells that can avoid forks. The arguments # must be portable across $(()) and expr. if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then : eval 'as_fn_arith () { as_val=$(( $* )) }' else as_fn_arith () { as_val=`expr "$@" || test $? -eq 1` } fi # as_fn_arith # as_fn_error ERROR [LINENO LOG_FD] # --------------------------------- # Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are # provided, also output the error to LOG_FD, referencing LINENO. Then exit the # script with status $?, using 1 if that was 0. as_fn_error () { as_status=$?; test $as_status -eq 0 && as_status=1 if test "$3"; then as_lineno=${as_lineno-"$2"} as_lineno_stack=as_lineno_stack=$as_lineno_stack $as_echo "$as_me:${as_lineno-$LINENO}: error: $1" >&$3 fi $as_echo "$as_me: error: $1" >&2 as_fn_exit $as_status } # as_fn_error if expr a : '\(a\)' >/dev/null 2>&1 && test "X`expr 00001 : '.*\(...\)'`" = X001; then as_expr=expr else as_expr=false fi if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then as_basename=basename else as_basename=false fi if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then as_dirname=dirname else as_dirname=false fi as_me=`$as_basename -- "$0" || $as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ X"$0" : 'X\(//\)$' \| \ X"$0" : 'X\(/\)' \| . 2>/dev/null || $as_echo X/"$0" | sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/ q } /^X\/\(\/\/\)$/{ s//\1/ q } /^X\/\(\/\).*/{ s//\1/ q } s/.*/./; q'` # Avoid depending upon Character Ranges. as_cr_letters='abcdefghijklmnopqrstuvwxyz' as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' as_cr_Letters=$as_cr_letters$as_cr_LETTERS as_cr_digits='0123456789' as_cr_alnum=$as_cr_Letters$as_cr_digits as_lineno_1=$LINENO as_lineno_1a=$LINENO as_lineno_2=$LINENO as_lineno_2a=$LINENO eval 'test "x$as_lineno_1'$as_run'" != "x$as_lineno_2'$as_run'" && test "x`expr $as_lineno_1'$as_run' + 1`" = "x$as_lineno_2'$as_run'"' || { # Blame Lee E. McMahon (1931-1989) for sed's syntax. :-) sed -n ' p /[$]LINENO/= ' <$as_myself | sed ' s/[$]LINENO.*/&-/ t lineno b :lineno N :loop s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/ t loop s/-\n.*// ' >$as_me.lineno && chmod +x "$as_me.lineno" || { $as_echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2; as_fn_exit 1; } # Don't try to exec as it changes $[0], causing all sort of problems # (the dirname of $[0] is not the place where we might find the # original and so on. Autoconf is especially sensitive to this). . "./$as_me.lineno" # Exit status is that of the last command. exit } ECHO_C= ECHO_N= ECHO_T= case `echo -n x` in #((((( -n*) case `echo 'xy\c'` in *c*) ECHO_T=' ';; # ECHO_T is single tab character. xy) ECHO_C='\c';; *) echo `echo ksh88 bug on AIX 6.1` > /dev/null ECHO_T=' ';; esac;; *) ECHO_N='-n';; esac rm -f conf$$ conf$$.exe conf$$.file if test -d conf$$.dir; then rm -f conf$$.dir/conf$$.file else rm -f conf$$.dir mkdir conf$$.dir 2>/dev/null fi if (echo >conf$$.file) 2>/dev/null; then if ln -s conf$$.file conf$$ 2>/dev/null; then as_ln_s='ln -s' # ... but there are two gotchas: # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. # In both cases, we have to default to `cp -p'. ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || as_ln_s='cp -p' elif ln conf$$.file conf$$ 2>/dev/null; then as_ln_s=ln else as_ln_s='cp -p' fi else as_ln_s='cp -p' fi rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file rmdir conf$$.dir 2>/dev/null if mkdir -p . 2>/dev/null; then as_mkdir_p='mkdir -p "$as_dir"' else test -d ./-p && rmdir ./-p as_mkdir_p=false fi if test -x / >/dev/null 2>&1; then as_test_x='test -x' else if ls -dL / >/dev/null 2>&1; then as_ls_L_option=L else as_ls_L_option= fi as_test_x=' eval sh -c '\'' if test -d "$1"; then test -d "$1/."; else case $1 in #( -*)set "./$1";; esac; case `ls -ld'$as_ls_L_option' "$1" 2>/dev/null` in #(( ???[sx]*):;;*)false;;esac;fi '\'' sh ' fi as_executable_p=$as_test_x # Sed expression to map a string onto a valid CPP name. as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" # Sed expression to map a string onto a valid variable name. as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" test -n "$DJDIR" || exec 7<&0 &1 # Name of the host. # hostname on some systems (SVR3.2, Linux) returns a bogus exit status, # so uname gets run too. ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q` # # Initializations. # ac_default_prefix=/usr/local ac_clean_files= ac_config_libobj_dir=. LIBOBJS= cross_compiling=no subdirs= MFLAGS= MAKEFLAGS= # Identity of this package. PACKAGE_NAME='mlpost' PACKAGE_TARNAME='mlpost' PACKAGE_VERSION='0.8.1' PACKAGE_STRING='mlpost 0.8.1' PACKAGE_BUGREPORT='' PACKAGE_URL='' ac_subst_vars='LTLIBOBJS LIBOBJS METAREQUIRESPACKAGE TODAY LIBDIR OBJEXT LIBEXT EXE OCAMLWIN32 BITSTRINGLIB INCLUDELIBS CAIROLIB TAGS CAIROLABLGTK2LIB CAIROLABLGTK2 LABLGTK2LIB INCLUDEGTK2 LABLGTK2 OCAMLFIND OCAMLVERSION OCAMLBEST PDFVIEWER PSVIEWER USEOCAMLFIND OCAMLWEB OCAMLBUILD OCAMLYACC OCAMLLEXDOTOPT OCAMLLEX OCAMLDEP OCAMLDOC CAMLP4O OCAMLOPTDOTOPT OCAMLCDOTOPT OCAMLOPT OCAMLC target_alias host_alias build_alias LIBS ECHO_T ECHO_N ECHO_C DEFS mandir localedir libdir psdir pdfdir dvidir htmldir infodir docdir oldincludedir includedir localstatedir sharedstatedir sysconfdir datadir datarootdir libexecdir sbindir bindir program_transform_name prefix exec_prefix PACKAGE_URL PACKAGE_BUGREPORT PACKAGE_STRING PACKAGE_VERSION PACKAGE_TARNAME PACKAGE_NAME PATH_SEPARATOR SHELL' ac_subst_files='' ac_user_opts=' enable_option_checking enable_cairo enable_concrete enable_lablgtk ' ac_precious_vars='build_alias host_alias target_alias' # Initialize some variables set by options. ac_init_help= ac_init_version=false ac_unrecognized_opts= ac_unrecognized_sep= # The variables have the same names as the options, with # dashes changed to underlines. cache_file=/dev/null exec_prefix=NONE no_create= no_recursion= prefix=NONE program_prefix=NONE program_suffix=NONE program_transform_name=s,x,x, silent= site= srcdir= verbose= x_includes=NONE x_libraries=NONE # Installation directory options. # These are left unexpanded so users can "make install exec_prefix=/foo" # and all the variables that are supposed to be based on exec_prefix # by default will actually change. # Use braces instead of parens because sh, perl, etc. also accept them. # (The list follows the same order as the GNU Coding Standards.) bindir='${exec_prefix}/bin' sbindir='${exec_prefix}/sbin' libexecdir='${exec_prefix}/libexec' datarootdir='${prefix}/share' datadir='${datarootdir}' sysconfdir='${prefix}/etc' sharedstatedir='${prefix}/com' localstatedir='${prefix}/var' includedir='${prefix}/include' oldincludedir='/usr/include' docdir='${datarootdir}/doc/${PACKAGE_TARNAME}' infodir='${datarootdir}/info' htmldir='${docdir}' dvidir='${docdir}' pdfdir='${docdir}' psdir='${docdir}' libdir='${exec_prefix}/lib' localedir='${datarootdir}/locale' mandir='${datarootdir}/man' ac_prev= ac_dashdash= for ac_option do # If the previous option needs an argument, assign it. if test -n "$ac_prev"; then eval $ac_prev=\$ac_option ac_prev= continue fi case $ac_option in *=*) ac_optarg=`expr "X$ac_option" : '[^=]*=\(.*\)'` ;; *) ac_optarg=yes ;; esac # Accept the important Cygnus configure options, so we can diagnose typos. case $ac_dashdash$ac_option in --) ac_dashdash=yes ;; -bindir | --bindir | --bindi | --bind | --bin | --bi) ac_prev=bindir ;; -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*) bindir=$ac_optarg ;; -build | --build | --buil | --bui | --bu) ac_prev=build_alias ;; -build=* | --build=* | --buil=* | --bui=* | --bu=*) build_alias=$ac_optarg ;; -cache-file | --cache-file | --cache-fil | --cache-fi \ | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) ac_prev=cache_file ;; -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) cache_file=$ac_optarg ;; --config-cache | -C) cache_file=config.cache ;; -datadir | --datadir | --datadi | --datad) ac_prev=datadir ;; -datadir=* | --datadir=* | --datadi=* | --datad=*) datadir=$ac_optarg ;; -datarootdir | --datarootdir | --datarootdi | --datarootd | --dataroot \ | --dataroo | --dataro | --datar) ac_prev=datarootdir ;; -datarootdir=* | --datarootdir=* | --datarootdi=* | --datarootd=* \ | --dataroot=* | --dataroo=* | --dataro=* | --datar=*) datarootdir=$ac_optarg ;; -disable-* | --disable-*) ac_useropt=`expr "x$ac_option" : 'x-*disable-\(.*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error "invalid feature name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "enable_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--disable-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval enable_$ac_useropt=no ;; -docdir | --docdir | --docdi | --doc | --do) ac_prev=docdir ;; -docdir=* | --docdir=* | --docdi=* | --doc=* | --do=*) docdir=$ac_optarg ;; -dvidir | --dvidir | --dvidi | --dvid | --dvi | --dv) ac_prev=dvidir ;; -dvidir=* | --dvidir=* | --dvidi=* | --dvid=* | --dvi=* | --dv=*) dvidir=$ac_optarg ;; -enable-* | --enable-*) ac_useropt=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error "invalid feature name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "enable_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--enable-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval enable_$ac_useropt=\$ac_optarg ;; -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ | --exec | --exe | --ex) ac_prev=exec_prefix ;; -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \ | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \ | --exec=* | --exe=* | --ex=*) exec_prefix=$ac_optarg ;; -gas | --gas | --ga | --g) # Obsolete; use --with-gas. with_gas=yes ;; -help | --help | --hel | --he | -h) ac_init_help=long ;; -help=r* | --help=r* | --hel=r* | --he=r* | -hr*) ac_init_help=recursive ;; -help=s* | --help=s* | --hel=s* | --he=s* | -hs*) ac_init_help=short ;; -host | --host | --hos | --ho) ac_prev=host_alias ;; -host=* | --host=* | --hos=* | --ho=*) host_alias=$ac_optarg ;; -htmldir | --htmldir | --htmldi | --htmld | --html | --htm | --ht) ac_prev=htmldir ;; -htmldir=* | --htmldir=* | --htmldi=* | --htmld=* | --html=* | --htm=* \ | --ht=*) htmldir=$ac_optarg ;; -includedir | --includedir | --includedi | --included | --include \ | --includ | --inclu | --incl | --inc) ac_prev=includedir ;; -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \ | --includ=* | --inclu=* | --incl=* | --inc=*) includedir=$ac_optarg ;; -infodir | --infodir | --infodi | --infod | --info | --inf) ac_prev=infodir ;; -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*) infodir=$ac_optarg ;; -libdir | --libdir | --libdi | --libd) ac_prev=libdir ;; -libdir=* | --libdir=* | --libdi=* | --libd=*) libdir=$ac_optarg ;; -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \ | --libexe | --libex | --libe) ac_prev=libexecdir ;; -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \ | --libexe=* | --libex=* | --libe=*) libexecdir=$ac_optarg ;; -localedir | --localedir | --localedi | --localed | --locale) ac_prev=localedir ;; -localedir=* | --localedir=* | --localedi=* | --localed=* | --locale=*) localedir=$ac_optarg ;; -localstatedir | --localstatedir | --localstatedi | --localstated \ | --localstate | --localstat | --localsta | --localst | --locals) ac_prev=localstatedir ;; -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \ | --localstate=* | --localstat=* | --localsta=* | --localst=* | --locals=*) localstatedir=$ac_optarg ;; -mandir | --mandir | --mandi | --mand | --man | --ma | --m) ac_prev=mandir ;; -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*) mandir=$ac_optarg ;; -nfp | --nfp | --nf) # Obsolete; use --without-fp. with_fp=no ;; -no-create | --no-create | --no-creat | --no-crea | --no-cre \ | --no-cr | --no-c | -n) no_create=yes ;; -no-recursion | --no-recursion | --no-recursio | --no-recursi \ | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) no_recursion=yes ;; -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \ | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \ | --oldin | --oldi | --old | --ol | --o) ac_prev=oldincludedir ;; -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \ | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \ | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*) oldincludedir=$ac_optarg ;; -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) ac_prev=prefix ;; -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) prefix=$ac_optarg ;; -program-prefix | --program-prefix | --program-prefi | --program-pref \ | --program-pre | --program-pr | --program-p) ac_prev=program_prefix ;; -program-prefix=* | --program-prefix=* | --program-prefi=* \ | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*) program_prefix=$ac_optarg ;; -program-suffix | --program-suffix | --program-suffi | --program-suff \ | --program-suf | --program-su | --program-s) ac_prev=program_suffix ;; -program-suffix=* | --program-suffix=* | --program-suffi=* \ | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*) program_suffix=$ac_optarg ;; -program-transform-name | --program-transform-name \ | --program-transform-nam | --program-transform-na \ | --program-transform-n | --program-transform- \ | --program-transform | --program-transfor \ | --program-transfo | --program-transf \ | --program-trans | --program-tran \ | --progr-tra | --program-tr | --program-t) ac_prev=program_transform_name ;; -program-transform-name=* | --program-transform-name=* \ | --program-transform-nam=* | --program-transform-na=* \ | --program-transform-n=* | --program-transform-=* \ | --program-transform=* | --program-transfor=* \ | --program-transfo=* | --program-transf=* \ | --program-trans=* | --program-tran=* \ | --progr-tra=* | --program-tr=* | --program-t=*) program_transform_name=$ac_optarg ;; -pdfdir | --pdfdir | --pdfdi | --pdfd | --pdf | --pd) ac_prev=pdfdir ;; -pdfdir=* | --pdfdir=* | --pdfdi=* | --pdfd=* | --pdf=* | --pd=*) pdfdir=$ac_optarg ;; -psdir | --psdir | --psdi | --psd | --ps) ac_prev=psdir ;; -psdir=* | --psdir=* | --psdi=* | --psd=* | --ps=*) psdir=$ac_optarg ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil) silent=yes ;; -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) ac_prev=sbindir ;; -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ | --sbi=* | --sb=*) sbindir=$ac_optarg ;; -sharedstatedir | --sharedstatedir | --sharedstatedi \ | --sharedstated | --sharedstate | --sharedstat | --sharedsta \ | --sharedst | --shareds | --shared | --share | --shar \ | --sha | --sh) ac_prev=sharedstatedir ;; -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \ | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \ | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \ | --sha=* | --sh=*) sharedstatedir=$ac_optarg ;; -site | --site | --sit) ac_prev=site ;; -site=* | --site=* | --sit=*) site=$ac_optarg ;; -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) ac_prev=srcdir ;; -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) srcdir=$ac_optarg ;; -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \ | --syscon | --sysco | --sysc | --sys | --sy) ac_prev=sysconfdir ;; -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \ | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*) sysconfdir=$ac_optarg ;; -target | --target | --targe | --targ | --tar | --ta | --t) ac_prev=target_alias ;; -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*) target_alias=$ac_optarg ;; -v | -verbose | --verbose | --verbos | --verbo | --verb) verbose=yes ;; -version | --version | --versio | --versi | --vers | -V) ac_init_version=: ;; -with-* | --with-*) ac_useropt=`expr "x$ac_option" : 'x-*with-\([^=]*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error "invalid package name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "with_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--with-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval with_$ac_useropt=\$ac_optarg ;; -without-* | --without-*) ac_useropt=`expr "x$ac_option" : 'x-*without-\(.*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error "invalid package name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "with_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--without-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval with_$ac_useropt=no ;; --x) # Obsolete; use --with-x. with_x=yes ;; -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \ | --x-incl | --x-inc | --x-in | --x-i) ac_prev=x_includes ;; -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \ | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*) x_includes=$ac_optarg ;; -x-libraries | --x-libraries | --x-librarie | --x-librari \ | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l) ac_prev=x_libraries ;; -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) x_libraries=$ac_optarg ;; -*) as_fn_error "unrecognized option: \`$ac_option' Try \`$0 --help' for more information." ;; *=*) ac_envvar=`expr "x$ac_option" : 'x\([^=]*\)='` # Reject names that are not valid shell variable names. case $ac_envvar in #( '' | [0-9]* | *[!_$as_cr_alnum]* ) as_fn_error "invalid variable name: \`$ac_envvar'" ;; esac eval $ac_envvar=\$ac_optarg export $ac_envvar ;; *) # FIXME: should be removed in autoconf 3.0. $as_echo "$as_me: WARNING: you should use --build, --host, --target" >&2 expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null && $as_echo "$as_me: WARNING: invalid host type: $ac_option" >&2 : ${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option} ;; esac done if test -n "$ac_prev"; then ac_option=--`echo $ac_prev | sed 's/_/-/g'` as_fn_error "missing argument to $ac_option" fi if test -n "$ac_unrecognized_opts"; then case $enable_option_checking in no) ;; fatal) as_fn_error "unrecognized options: $ac_unrecognized_opts" ;; *) $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2 ;; esac fi # Check all directory arguments for consistency. for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \ datadir sysconfdir sharedstatedir localstatedir includedir \ oldincludedir docdir infodir htmldir dvidir pdfdir psdir \ libdir localedir mandir do eval ac_val=\$$ac_var # Remove trailing slashes. case $ac_val in */ ) ac_val=`expr "X$ac_val" : 'X\(.*[^/]\)' \| "X$ac_val" : 'X\(.*\)'` eval $ac_var=\$ac_val;; esac # Be sure to have absolute directory names. case $ac_val in [\\/$]* | ?:[\\/]* ) continue;; NONE | '' ) case $ac_var in *prefix ) continue;; esac;; esac as_fn_error "expected an absolute directory name for --$ac_var: $ac_val" done # There might be people who depend on the old broken behavior: `$host' # used to hold the argument of --host etc. # FIXME: To remove some day. build=$build_alias host=$host_alias target=$target_alias # FIXME: To remove some day. if test "x$host_alias" != x; then if test "x$build_alias" = x; then cross_compiling=maybe $as_echo "$as_me: WARNING: If you wanted to set the --build type, don't use --host. If a cross compiler is detected then cross compile mode will be used." >&2 elif test "x$build_alias" != "x$host_alias"; then cross_compiling=yes fi fi ac_tool_prefix= test -n "$host_alias" && ac_tool_prefix=$host_alias- test "$silent" = yes && exec 6>/dev/null ac_pwd=`pwd` && test -n "$ac_pwd" && ac_ls_di=`ls -di .` && ac_pwd_ls_di=`cd "$ac_pwd" && ls -di .` || as_fn_error "working directory cannot be determined" test "X$ac_ls_di" = "X$ac_pwd_ls_di" || as_fn_error "pwd does not report name of working directory" # Find the source files, if location was not specified. if test -z "$srcdir"; then ac_srcdir_defaulted=yes # Try the directory containing this script, then the parent directory. ac_confdir=`$as_dirname -- "$as_myself" || $as_expr X"$as_myself" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_myself" : 'X\(//\)[^/]' \| \ X"$as_myself" : 'X\(//\)$' \| \ X"$as_myself" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$as_myself" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` srcdir=$ac_confdir if test ! -r "$srcdir/$ac_unique_file"; then srcdir=.. fi else ac_srcdir_defaulted=no fi if test ! -r "$srcdir/$ac_unique_file"; then test "$ac_srcdir_defaulted" = yes && srcdir="$ac_confdir or .." as_fn_error "cannot find sources ($ac_unique_file) in $srcdir" fi ac_msg="sources are in $srcdir, but \`cd $srcdir' does not work" ac_abs_confdir=`( cd "$srcdir" && test -r "./$ac_unique_file" || as_fn_error "$ac_msg" pwd)` # When building in place, set srcdir=. if test "$ac_abs_confdir" = "$ac_pwd"; then srcdir=. fi # Remove unnecessary trailing slashes from srcdir. # Double slashes in file names in object file debugging info # mess up M-x gdb in Emacs. case $srcdir in */) srcdir=`expr "X$srcdir" : 'X\(.*[^/]\)' \| "X$srcdir" : 'X\(.*\)'`;; esac for ac_var in $ac_precious_vars; do eval ac_env_${ac_var}_set=\${${ac_var}+set} eval ac_env_${ac_var}_value=\$${ac_var} eval ac_cv_env_${ac_var}_set=\${${ac_var}+set} eval ac_cv_env_${ac_var}_value=\$${ac_var} done # # Report the --help message. # if test "$ac_init_help" = "long"; then # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF \`configure' configures mlpost 0.8.1 to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... To assign environment variables (e.g., CC, CFLAGS...), specify them as VAR=VALUE. See below for descriptions of some of the useful variables. Defaults for the options are specified in brackets. Configuration: -h, --help display this help and exit --help=short display options specific to this package --help=recursive display the short help of all the included packages -V, --version display version information and exit -q, --quiet, --silent do not print \`checking...' messages --cache-file=FILE cache test results in FILE [disabled] -C, --config-cache alias for \`--cache-file=config.cache' -n, --no-create do not create output files --srcdir=DIR find the sources in DIR [configure dir or \`..'] Installation directories: --prefix=PREFIX install architecture-independent files in PREFIX [$ac_default_prefix] --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX [PREFIX] By default, \`make install' will install all the files in \`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc. You can specify an installation prefix other than \`$ac_default_prefix' using \`--prefix', for instance \`--prefix=\$HOME'. For better control, use the options below. Fine tuning of the installation directories: --bindir=DIR user executables [EPREFIX/bin] --sbindir=DIR system admin executables [EPREFIX/sbin] --libexecdir=DIR program executables [EPREFIX/libexec] --sysconfdir=DIR read-only single-machine data [PREFIX/etc] --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com] --localstatedir=DIR modifiable single-machine data [PREFIX/var] --libdir=DIR object code libraries [EPREFIX/lib] --includedir=DIR C header files [PREFIX/include] --oldincludedir=DIR C header files for non-gcc [/usr/include] --datarootdir=DIR read-only arch.-independent data root [PREFIX/share] --datadir=DIR read-only architecture-independent data [DATAROOTDIR] --infodir=DIR info documentation [DATAROOTDIR/info] --localedir=DIR locale-dependent data [DATAROOTDIR/locale] --mandir=DIR man documentation [DATAROOTDIR/man] --docdir=DIR documentation root [DATAROOTDIR/doc/mlpost] --htmldir=DIR html documentation [DOCDIR] --dvidir=DIR dvi documentation [DOCDIR] --pdfdir=DIR pdf documentation [DOCDIR] --psdir=DIR ps documentation [DOCDIR] _ACEOF cat <<\_ACEOF _ACEOF fi if test -n "$ac_init_help"; then case $ac_init_help in short | recursive ) echo "Configuration of mlpost 0.8.1:";; esac cat <<\_ACEOF Optional Features: --disable-option-checking ignore unrecognized --enable/--with options --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no) --enable-FEATURE[=ARG] include FEATURE [ARG=yes] --enable-cairo enable the cairo backend (requires cairo library, implies --enable-concrete)default=yes --enable-concrete enable concrete computations (requires bitstring library) default=yes --enable-lablgtk enable the cairo backend (requires cairo library, implies --enable-lablgtk)default=yes Report bugs to the package provider. _ACEOF ac_status=$? fi if test "$ac_init_help" = "recursive"; then # If there are subdirs, report their specific --help. for ac_dir in : $ac_subdirs_all; do test "x$ac_dir" = x: && continue test -d "$ac_dir" || { cd "$srcdir" && ac_pwd=`pwd` && srcdir=. && test -d "$ac_dir"; } || continue ac_builddir=. case "$ac_dir" in .) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'` # A ".." for each directory in $ac_dir_suffix. ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` case $ac_top_builddir_sub in "") ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; esac ;; esac ac_abs_top_builddir=$ac_pwd ac_abs_builddir=$ac_pwd$ac_dir_suffix # for backward compatibility: ac_top_builddir=$ac_top_build_prefix case $srcdir in .) # We are building in place. ac_srcdir=. ac_top_srcdir=$ac_top_builddir_sub ac_abs_top_srcdir=$ac_pwd ;; [\\/]* | ?:[\\/]* ) # Absolute name. ac_srcdir=$srcdir$ac_dir_suffix; ac_top_srcdir=$srcdir ac_abs_top_srcdir=$srcdir ;; *) # Relative name. ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix ac_top_srcdir=$ac_top_build_prefix$srcdir ac_abs_top_srcdir=$ac_pwd/$srcdir ;; esac ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix cd "$ac_dir" || { ac_status=$?; continue; } # Check for guested configure. if test -f "$ac_srcdir/configure.gnu"; then echo && $SHELL "$ac_srcdir/configure.gnu" --help=recursive elif test -f "$ac_srcdir/configure"; then echo && $SHELL "$ac_srcdir/configure" --help=recursive else $as_echo "$as_me: WARNING: no configuration information is in $ac_dir" >&2 fi || ac_status=$? cd "$ac_pwd" || { ac_status=$?; break; } done fi test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then cat <<\_ACEOF mlpost configure 0.8.1 generated by GNU Autoconf 2.65 Copyright (C) 2009 Free Software Foundation, Inc. This configure script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it. _ACEOF exit fi ## ------------------------ ## ## Autoconf initialization. ## ## ------------------------ ## cat >config.log <<_ACEOF This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. It was created by mlpost $as_me 0.8.1, which was generated by GNU Autoconf 2.65. Invocation command line was $ $0 $@ _ACEOF exec 5>>config.log { cat <<_ASUNAME ## --------- ## ## Platform. ## ## --------- ## hostname = `(hostname || uname -n) 2>/dev/null | sed 1q` uname -m = `(uname -m) 2>/dev/null || echo unknown` uname -r = `(uname -r) 2>/dev/null || echo unknown` uname -s = `(uname -s) 2>/dev/null || echo unknown` uname -v = `(uname -v) 2>/dev/null || echo unknown` /usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null || echo unknown` /bin/uname -X = `(/bin/uname -X) 2>/dev/null || echo unknown` /bin/arch = `(/bin/arch) 2>/dev/null || echo unknown` /usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null || echo unknown` /usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null || echo unknown` /usr/bin/hostinfo = `(/usr/bin/hostinfo) 2>/dev/null || echo unknown` /bin/machine = `(/bin/machine) 2>/dev/null || echo unknown` /usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null || echo unknown` /bin/universe = `(/bin/universe) 2>/dev/null || echo unknown` _ASUNAME as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. $as_echo "PATH: $as_dir" done IFS=$as_save_IFS } >&5 cat >&5 <<_ACEOF ## ----------- ## ## Core tests. ## ## ----------- ## _ACEOF # Keep a trace of the command line. # Strip out --no-create and --no-recursion so they do not pile up. # Strip out --silent because we don't want to record it for future runs. # Also quote any args containing shell meta-characters. # Make two passes to allow for proper duplicate-argument suppression. ac_configure_args= ac_configure_args0= ac_configure_args1= ac_must_keep_next=false for ac_pass in 1 2 do for ac_arg do case $ac_arg in -no-create | --no-c* | -n | -no-recursion | --no-r*) continue ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil) continue ;; *\'*) ac_arg=`$as_echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; esac case $ac_pass in 1) as_fn_append ac_configure_args0 " '$ac_arg'" ;; 2) as_fn_append ac_configure_args1 " '$ac_arg'" if test $ac_must_keep_next = true; then ac_must_keep_next=false # Got value, back to normal. else case $ac_arg in *=* | --config-cache | -C | -disable-* | --disable-* \ | -enable-* | --enable-* | -gas | --g* | -nfp | --nf* \ | -q | -quiet | --q* | -silent | --sil* | -v | -verb* \ | -with-* | --with-* | -without-* | --without-* | --x) case "$ac_configure_args0 " in "$ac_configure_args1"*" '$ac_arg' "* ) continue ;; esac ;; -* ) ac_must_keep_next=true ;; esac fi as_fn_append ac_configure_args " '$ac_arg'" ;; esac done done { ac_configure_args0=; unset ac_configure_args0;} { ac_configure_args1=; unset ac_configure_args1;} # When interrupted or exit'd, cleanup temporary files, and complete # config.log. We remove comments because anyway the quotes in there # would cause problems or look ugly. # WARNING: Use '\'' to represent an apostrophe within the trap. # WARNING: Do not start the trap code with a newline, due to a FreeBSD 4.0 bug. trap 'exit_status=$? # Save into config.log some information that might help in debugging. { echo cat <<\_ASBOX ## ---------------- ## ## Cache variables. ## ## ---------------- ## _ASBOX echo # The following way of writing the cache mishandles newlines in values, ( for ac_var in `(set) 2>&1 | sed -n '\''s/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'\''`; do eval ac_val=\$$ac_var case $ac_val in #( *${as_nl}*) case $ac_var in #( *_cv_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 $as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; esac case $ac_var in #( _ | IFS | as_nl) ;; #( BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( *) { eval $ac_var=; unset $ac_var;} ;; esac ;; esac done (set) 2>&1 | case $as_nl`(ac_space='\'' '\''; set) 2>&1` in #( *${as_nl}ac_space=\ *) sed -n \ "s/'\''/'\''\\\\'\'''\''/g; s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\''\\2'\''/p" ;; #( *) sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" ;; esac | sort ) echo cat <<\_ASBOX ## ----------------- ## ## Output variables. ## ## ----------------- ## _ASBOX echo for ac_var in $ac_subst_vars do eval ac_val=\$$ac_var case $ac_val in *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; esac $as_echo "$ac_var='\''$ac_val'\''" done | sort echo if test -n "$ac_subst_files"; then cat <<\_ASBOX ## ------------------- ## ## File substitutions. ## ## ------------------- ## _ASBOX echo for ac_var in $ac_subst_files do eval ac_val=\$$ac_var case $ac_val in *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; esac $as_echo "$ac_var='\''$ac_val'\''" done | sort echo fi if test -s confdefs.h; then cat <<\_ASBOX ## ----------- ## ## confdefs.h. ## ## ----------- ## _ASBOX echo cat confdefs.h echo fi test "$ac_signal" != 0 && $as_echo "$as_me: caught signal $ac_signal" $as_echo "$as_me: exit $exit_status" } >&5 rm -f core *.core core.conftest.* && rm -f -r conftest* confdefs* conf$$* $ac_clean_files && exit $exit_status ' 0 for ac_signal in 1 2 13 15; do trap 'ac_signal='$ac_signal'; as_fn_exit 1' $ac_signal done ac_signal=0 # confdefs.h avoids OS command line length limits that DEFS can exceed. rm -f -r conftest* confdefs.h $as_echo "/* confdefs.h */" > confdefs.h # Predefined preprocessor variables. cat >>confdefs.h <<_ACEOF #define PACKAGE_NAME "$PACKAGE_NAME" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_TARNAME "$PACKAGE_TARNAME" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_VERSION "$PACKAGE_VERSION" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_STRING "$PACKAGE_STRING" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_BUGREPORT "$PACKAGE_BUGREPORT" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_URL "$PACKAGE_URL" _ACEOF # Let the site file select an alternate cache file if it wants to. # Prefer an explicitly selected file to automatically selected ones. ac_site_file1=NONE ac_site_file2=NONE if test -n "$CONFIG_SITE"; then ac_site_file1=$CONFIG_SITE elif test "x$prefix" != xNONE; then ac_site_file1=$prefix/share/config.site ac_site_file2=$prefix/etc/config.site else ac_site_file1=$ac_default_prefix/share/config.site ac_site_file2=$ac_default_prefix/etc/config.site fi for ac_site_file in "$ac_site_file1" "$ac_site_file2" do test "x$ac_site_file" = xNONE && continue if test /dev/null != "$ac_site_file" && test -r "$ac_site_file"; then { $as_echo "$as_me:${as_lineno-$LINENO}: loading site script $ac_site_file" >&5 $as_echo "$as_me: loading site script $ac_site_file" >&6;} sed 's/^/| /' "$ac_site_file" >&5 . "$ac_site_file" fi done if test -r "$cache_file"; then # Some versions of bash will fail to source /dev/null (special files # actually), so we avoid doing that. DJGPP emulates it as a regular file. if test /dev/null != "$cache_file" && test -f "$cache_file"; then { $as_echo "$as_me:${as_lineno-$LINENO}: loading cache $cache_file" >&5 $as_echo "$as_me: loading cache $cache_file" >&6;} case $cache_file in [\\/]* | ?:[\\/]* ) . "$cache_file";; *) . "./$cache_file";; esac fi else { $as_echo "$as_me:${as_lineno-$LINENO}: creating cache $cache_file" >&5 $as_echo "$as_me: creating cache $cache_file" >&6;} >$cache_file fi # Check that the precious variables saved in the cache have kept the same # value. ac_cache_corrupted=false for ac_var in $ac_precious_vars; do eval ac_old_set=\$ac_cv_env_${ac_var}_set eval ac_new_set=\$ac_env_${ac_var}_set eval ac_old_val=\$ac_cv_env_${ac_var}_value eval ac_new_val=\$ac_env_${ac_var}_value case $ac_old_set,$ac_new_set in set,) { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5 $as_echo "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;} ac_cache_corrupted=: ;; ,set) { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was not set in the previous run" >&5 $as_echo "$as_me: error: \`$ac_var' was not set in the previous run" >&2;} ac_cache_corrupted=: ;; ,);; *) if test "x$ac_old_val" != "x$ac_new_val"; then # differences in whitespace do not lead to failure. ac_old_val_w=`echo x $ac_old_val` ac_new_val_w=`echo x $ac_new_val` if test "$ac_old_val_w" != "$ac_new_val_w"; then { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' has changed since the previous run:" >&5 $as_echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;} ac_cache_corrupted=: else { $as_echo "$as_me:${as_lineno-$LINENO}: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&5 $as_echo "$as_me: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&2;} eval $ac_var=\$ac_old_val fi { $as_echo "$as_me:${as_lineno-$LINENO}: former value: \`$ac_old_val'" >&5 $as_echo "$as_me: former value: \`$ac_old_val'" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: current value: \`$ac_new_val'" >&5 $as_echo "$as_me: current value: \`$ac_new_val'" >&2;} fi;; esac # Pass precious variables to config.status. if test "$ac_new_set" = set; then case $ac_new_val in *\'*) ac_arg=$ac_var=`$as_echo "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;; *) ac_arg=$ac_var=$ac_new_val ;; esac case " $ac_configure_args " in *" '$ac_arg' "*) ;; # Avoid dups. Use of quotes ensures accuracy. *) as_fn_append ac_configure_args " '$ac_arg'" ;; esac fi done if $ac_cache_corrupted; then { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: error: changes in the environment can compromise the build" >&5 $as_echo "$as_me: error: changes in the environment can compromise the build" >&2;} as_fn_error "run \`make distclean' and/or \`rm $cache_file' and start over" "$LINENO" 5 fi ## -------------------- ## ## Main body of script. ## ## -------------------- ## ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu # The compilation date TODAY=`date` # Check for Ocaml compilers # we first look for ocamlc in the path; if not present, we fail # Extract the first word of "ocamlc", so it can be a program name with args. set dummy ocamlc; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if test "${ac_cv_path_OCAMLC+set}" = set; then : $as_echo_n "(cached) " >&6 else case $OCAMLC in [\\/]* | ?:[\\/]*) ac_cv_path_OCAMLC="$OCAMLC" # Let the user override the test with a path. ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_path_OCAMLC="$as_dir/$ac_word$ac_exec_ext" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS test -z "$ac_cv_path_OCAMLC" && ac_cv_path_OCAMLC="no" ;; esac fi OCAMLC=$ac_cv_path_OCAMLC if test -n "$OCAMLC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLC" >&5 $as_echo "$OCAMLC" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "$OCAMLC" = no ; then as_fn_error "Cannot find ocamlc." "$LINENO" 5 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 3.10.0*) as_fn_error "ocamlbuild is too buggy in this version. Aborting." "$LINENO" 5 ;; 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 # Extract the first word of "ocamlopt", so it can be a program name with args. set dummy ocamlopt; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if test "${ac_cv_path_OCAMLOPT+set}" = set; then : $as_echo_n "(cached) " >&6 else case $OCAMLOPT in [\\/]* | ?:[\\/]*) ac_cv_path_OCAMLOPT="$OCAMLOPT" # Let the user override the test with a path. ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_path_OCAMLOPT="$as_dir/$ac_word$ac_exec_ext" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS test -z "$ac_cv_path_OCAMLOPT" && ac_cv_path_OCAMLOPT="no" ;; esac fi OCAMLOPT=$ac_cv_path_OCAMLOPT if test -n "$OCAMLOPT"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLOPT" >&5 $as_echo "$OCAMLOPT" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi OCAMLBEST=byte if test "$OCAMLOPT" = no ; then { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: Cannot find ocamlopt; bytecode compilation only." >&5 $as_echo "$as_me: WARNING: Cannot find ocamlopt; bytecode compilation only." >&2;} else { $as_echo "$as_me:${as_lineno-$LINENO}: checking ocamlopt version" >&5 $as_echo_n "checking ocamlopt version... " >&6; } TMPVERSION=`$OCAMLOPT -v | sed -n -e 's|.*version *\(.*\)$|\1|p' ` if test "$TMPVERSION" != "$OCAMLVERSION" ; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: differs from ocamlc; ocamlopt discarded." >&5 $as_echo "differs from ocamlc; ocamlopt discarded." >&6; } OCAMLOPT=no else { $as_echo "$as_me:${as_lineno-$LINENO}: result: ok" >&5 $as_echo "ok" >&6; } OCAMLBEST=opt fi fi # checking for ocamlc.opt # Extract the first word of "ocamlc.opt", so it can be a program name with args. set dummy ocamlc.opt; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if test "${ac_cv_path_OCAMLCDOTOPT+set}" = set; then : $as_echo_n "(cached) " >&6 else case $OCAMLCDOTOPT in [\\/]* | ?:[\\/]*) ac_cv_path_OCAMLCDOTOPT="$OCAMLCDOTOPT" # Let the user override the test with a path. ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_path_OCAMLCDOTOPT="$as_dir/$ac_word$ac_exec_ext" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS test -z "$ac_cv_path_OCAMLCDOTOPT" && ac_cv_path_OCAMLCDOTOPT="no" ;; esac fi OCAMLCDOTOPT=$ac_cv_path_OCAMLCDOTOPT if test -n "$OCAMLCDOTOPT"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLCDOTOPT" >&5 $as_echo "$OCAMLCDOTOPT" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "$OCAMLCDOTOPT" != no ; then { $as_echo "$as_me:${as_lineno-$LINENO}: checking ocamlc.opt version" >&5 $as_echo_n "checking ocamlc.opt version... " >&6; } TMPVERSION=`$OCAMLCDOTOPT -v | sed -n -e 's|.*version *\(.*\)$|\1|p' ` if test "$TMPVERSION" != "$OCAMLVERSION" ; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: differs from ocamlc; ocamlc.opt discarded." >&5 $as_echo "differs from ocamlc; ocamlc.opt discarded." >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: ok" >&5 $as_echo "ok" >&6; } OCAMLC=$OCAMLCDOTOPT fi fi # checking for ocamlopt.opt if test "$OCAMLOPT" != no ; then # Extract the first word of "ocamlopt.opt", so it can be a program name with args. set dummy ocamlopt.opt; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if test "${ac_cv_path_OCAMLOPTDOTOPT+set}" = set; then : $as_echo_n "(cached) " >&6 else case $OCAMLOPTDOTOPT in [\\/]* | ?:[\\/]*) ac_cv_path_OCAMLOPTDOTOPT="$OCAMLOPTDOTOPT" # Let the user override the test with a path. ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_path_OCAMLOPTDOTOPT="$as_dir/$ac_word$ac_exec_ext" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS test -z "$ac_cv_path_OCAMLOPTDOTOPT" && ac_cv_path_OCAMLOPTDOTOPT="no" ;; esac fi OCAMLOPTDOTOPT=$ac_cv_path_OCAMLOPTDOTOPT if test -n "$OCAMLOPTDOTOPT"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLOPTDOTOPT" >&5 $as_echo "$OCAMLOPTDOTOPT" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "$OCAMLOPTDOTOPT" != no ; then { $as_echo "$as_me:${as_lineno-$LINENO}: checking ocamlc.opt version" >&5 $as_echo_n "checking ocamlc.opt version... " >&6; } TMPVER=`$OCAMLOPTDOTOPT -v | sed -n -e 's|.*version *\(.*\)$|\1|p' ` if test "$TMPVER" != "$OCAMLVERSION" ; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: differs from ocamlc; ocamlopt.opt discarded." >&5 $as_echo "differs from ocamlc; ocamlopt.opt discarded." >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: ok" >&5 $as_echo "ok" >&6; } OCAMLOPT=$OCAMLOPTDOTOPT fi fi fi # checking for camlp4o # Extract the first word of "camlp4o", so it can be a program name with args. set dummy camlp4o; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if test "${ac_cv_path_CAMLP4O+set}" = set; then : $as_echo_n "(cached) " >&6 else case $CAMLP4O in [\\/]* | ?:[\\/]*) ac_cv_path_CAMLP4O="$CAMLP4O" # Let the user override the test with a path. ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_path_CAMLP4O="$as_dir/$ac_word$ac_exec_ext" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS test -z "$ac_cv_path_CAMLP4O" && ac_cv_path_CAMLP4O="no" ;; esac fi CAMLP4O=$ac_cv_path_CAMLP4O if test -n "$CAMLP4O"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CAMLP4O" >&5 $as_echo "$CAMLP4O" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "$CAMLP4O" != no ; then { $as_echo "$as_me:${as_lineno-$LINENO}: checking camlp4o version" >&5 $as_echo_n "checking camlp4o version... " >&6; } TMPVER=`$CAMLP4O -version` if test "$TMPVER" != "$OCAMLVERSION" ; then as_fn_error "differs from ocamlc; Aborting." "$LINENO" 5 else { $as_echo "$as_me:${as_lineno-$LINENO}: result: ok" >&5 $as_echo "ok" >&6; } 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 # Extract the first word of "ocamldoc", so it can be a program name with args. set dummy ocamldoc; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if test "${ac_cv_path_OCAMLDOC+set}" = set; then : $as_echo_n "(cached) " >&6 else case $OCAMLDOC in [\\/]* | ?:[\\/]*) ac_cv_path_OCAMLDOC="$OCAMLDOC" # Let the user override the test with a path. ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_path_OCAMLDOC="$as_dir/$ac_word$ac_exec_ext" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS test -z "$ac_cv_path_OCAMLDOC" && ac_cv_path_OCAMLDOC="no" ;; esac fi OCAMLDOC=$ac_cv_path_OCAMLDOC if test -n "$OCAMLDOC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLDOC" >&5 $as_echo "$OCAMLDOC" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi # ocamldep, ocamllex and ocamlyacc should also be present in the path # Extract the first word of "ocamldep", so it can be a program name with args. set dummy ocamldep; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if test "${ac_cv_path_OCAMLDEP+set}" = set; then : $as_echo_n "(cached) " >&6 else case $OCAMLDEP in [\\/]* | ?:[\\/]*) ac_cv_path_OCAMLDEP="$OCAMLDEP" # Let the user override the test with a path. ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_path_OCAMLDEP="$as_dir/$ac_word$ac_exec_ext" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS test -z "$ac_cv_path_OCAMLDEP" && ac_cv_path_OCAMLDEP="no" ;; esac fi OCAMLDEP=$ac_cv_path_OCAMLDEP if test -n "$OCAMLDEP"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLDEP" >&5 $as_echo "$OCAMLDEP" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "$OCAMLDEP" = no ; then as_fn_error "Cannot find ocamldep." "$LINENO" 5 fi # Extract the first word of "ocamllex", so it can be a program name with args. set dummy ocamllex; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if test "${ac_cv_path_OCAMLLEX+set}" = set; then : $as_echo_n "(cached) " >&6 else case $OCAMLLEX in [\\/]* | ?:[\\/]*) ac_cv_path_OCAMLLEX="$OCAMLLEX" # Let the user override the test with a path. ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_path_OCAMLLEX="$as_dir/$ac_word$ac_exec_ext" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS test -z "$ac_cv_path_OCAMLLEX" && ac_cv_path_OCAMLLEX="no" ;; esac fi OCAMLLEX=$ac_cv_path_OCAMLLEX if test -n "$OCAMLLEX"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLLEX" >&5 $as_echo "$OCAMLLEX" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "$OCAMLLEX" = no ; then as_fn_error "Cannot find ocamllex." "$LINENO" 5 else # Extract the first word of "ocamllex.opt", so it can be a program name with args. set dummy ocamllex.opt; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if test "${ac_cv_path_OCAMLLEXDOTOPT+set}" = set; then : $as_echo_n "(cached) " >&6 else case $OCAMLLEXDOTOPT in [\\/]* | ?:[\\/]*) ac_cv_path_OCAMLLEXDOTOPT="$OCAMLLEXDOTOPT" # Let the user override the test with a path. ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_path_OCAMLLEXDOTOPT="$as_dir/$ac_word$ac_exec_ext" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS test -z "$ac_cv_path_OCAMLLEXDOTOPT" && ac_cv_path_OCAMLLEXDOTOPT="no" ;; esac fi OCAMLLEXDOTOPT=$ac_cv_path_OCAMLLEXDOTOPT if test -n "$OCAMLLEXDOTOPT"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLLEXDOTOPT" >&5 $as_echo "$OCAMLLEXDOTOPT" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "$OCAMLLEXDOTOPT" != no ; then OCAMLLEX=$OCAMLLEXDOTOPT fi fi # Extract the first word of "ocamlyacc", so it can be a program name with args. set dummy ocamlyacc; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if test "${ac_cv_path_OCAMLYACC+set}" = set; then : $as_echo_n "(cached) " >&6 else case $OCAMLYACC in [\\/]* | ?:[\\/]*) ac_cv_path_OCAMLYACC="$OCAMLYACC" # Let the user override the test with a path. ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_path_OCAMLYACC="$as_dir/$ac_word$ac_exec_ext" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS test -z "$ac_cv_path_OCAMLYACC" && ac_cv_path_OCAMLYACC="no" ;; esac fi OCAMLYACC=$ac_cv_path_OCAMLYACC if test -n "$OCAMLYACC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLYACC" >&5 $as_echo "$OCAMLYACC" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "$OCAMLYACC" = no ; then as_fn_error "Cannot find ocamlyacc." "$LINENO" 5 fi #First check that the versions for ocamlbuild are OK # Extract the first word of "ocamlbuild", so it can be a program name with args. set dummy ocamlbuild; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if test "${ac_cv_path_OCAMLBUILD+set}" = set; then : $as_echo_n "(cached) " >&6 else case $OCAMLBUILD in [\\/]* | ?:[\\/]*) ac_cv_path_OCAMLBUILD="$OCAMLBUILD" # Let the user override the test with a path. ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_path_OCAMLBUILD="$as_dir/$ac_word$ac_exec_ext" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS test -z "$ac_cv_path_OCAMLBUILD" && ac_cv_path_OCAMLBUILD="no" ;; esac fi OCAMLBUILD=$ac_cv_path_OCAMLBUILD if test -n "$OCAMLBUILD"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLBUILD" >&5 $as_echo "$OCAMLBUILD" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "$OCAMLBUILD" = no; then as_fn_error "Cannot find ocamlbuild." "$LINENO" 5 else { $as_echo "$as_me:${as_lineno-$LINENO}: checking ocamlbuild version" >&5 $as_echo_n "checking ocamlbuild version... " >&6; } TMPVER=`$OCAMLBUILD -version | sed -n -e 's|.*ocamlbuild *\(.*\)$|\1|p' ` case $OCAMLVERSION in 3.10.1|3.10.2*) if test "$TMPVER" != "0.1"; then as_fn_error "ocamlbuild version differs from ocamlc. Aborting." "$LINENO" 5 else { $as_echo "$as_me:${as_lineno-$LINENO}: result: ok" >&5 $as_echo "ok" >&6; } fi ;; *) if test "$TMPVER" != "$OCAMLVERSION" ; then as_fn_error "ocamlbuild version differs from ocamlc. Aborting." "$LINENO" 5 else { $as_echo "$as_me:${as_lineno-$LINENO}: result: ok" >&5 $as_echo "ok" >&6; } fi ;; esac fi # Then check that we are dealing with ocamlbuild at the right place { $as_echo "$as_me:${as_lineno-$LINENO}: checking ocamlbuild place" >&5 $as_echo_n "checking ocamlbuild place... " >&6; } OCAMLBUILDLIB=$(ocamlbuild -where) if test "$OCAMLBUILDLIB" != "${OCAMLLIB}/ocamlbuild"; then echo "ocamlbuild present but your ocamlbuild is not compatible with your ocamlc:" echo "ocamlbuild : $OCAMLBUILDLIB, ocamlc : $OCAMLLIB" as_fn_error "ocamlbuild not at the right place" "$LINENO" 5 else { $as_echo "$as_me:${as_lineno-$LINENO}: result: ok" >&5 $as_echo "ok" >&6; } fi # Extract the first word of "ocamlweb", so it can be a program name with args. set dummy ocamlweb; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if test "${ac_cv_path_OCAMLWEB+set}" = set; then : $as_echo_n "(cached) " >&6 else case $OCAMLWEB in [\\/]* | ?:[\\/]*) ac_cv_path_OCAMLWEB="$OCAMLWEB" # Let the user override the test with a path. ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_path_OCAMLWEB="$as_dir/$ac_word$ac_exec_ext" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS test -z "$ac_cv_path_OCAMLWEB" && ac_cv_path_OCAMLWEB="true" ;; esac fi OCAMLWEB=$ac_cv_path_OCAMLWEB if test -n "$OCAMLWEB"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLWEB" >&5 $as_echo "$OCAMLWEB" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi # platform { $as_echo "$as_me:${as_lineno-$LINENO}: checking platform" >&5 $as_echo_n "checking platform... " >&6; } if echo "let _ = Sys.os_type" | ocaml | grep -q Win32; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: Win32" >&5 $as_echo "Win32" >&6; } OCAMLWIN32=yes EXE=.exe LIBEXT=.lib OBJEXT=.obj else { $as_echo "$as_me:${as_lineno-$LINENO}: result: not Win32" >&5 $as_echo "not Win32" >&6; } 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 # Extract the first word of "ocamlfind", so it can be a program name with args. set dummy ocamlfind; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if test "${ac_cv_prog_USEOCAMLFIND+set}" = set; then : $as_echo_n "(cached) " >&6 else if test -n "$USEOCAMLFIND"; then ac_cv_prog_USEOCAMLFIND="$USEOCAMLFIND" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_prog_USEOCAMLFIND="yes" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS test -z "$ac_cv_prog_USEOCAMLFIND" && ac_cv_prog_USEOCAMLFIND="no" fi fi USEOCAMLFIND=$ac_cv_prog_USEOCAMLFIND if test -n "$USEOCAMLFIND"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $USEOCAMLFIND" >&5 $as_echo "$USEOCAMLFIND" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "$USEOCAMLFIND" = yes; then OCAMLFINDLIB=$(ocamlfind printconf stdlib) OCAMLFIND=$(which ocamlfind) if test "$OCAMLFINDLIB" != "$OCAMLLIB"; then USEOCAMLFIND=no; echo "but your ocamlfind is not compatible with your ocamlc:" echo "ocamlfind : $OCAMLFINDLIB, ocamlc : $OCAMLLIB" fi fi if test "$LIBDIR" = ""; then if test "$USEOCAMLFIND" = yes; then LIBDIR=$(ocamlfind printconf destdir)/mlpost else LIBDIR=$OCAMLLIB/mlpost fi fi echo "Mlpost library will be installed in: $LIBDIR" # Check whether --enable-cairo was given. if test "${enable_cairo+set}" = set; then : enableval=$enable_cairo; else enable_cairo=yes fi CAIRO=no if test "$enable_cairo" = yes; then # checking for mlcairo if test "$USEOCAMLFIND" = yes; then CAIROLIB=$(ocamlfind query cairo) fi if test -n "$CAIROLIB";then echo "ocamlfind found cairo in $CAIROLIB" CAIRO=yes else as_ac_File=`$as_echo "ac_cv_file_$OCAMLLIB/cairo/cairo.cma" | $as_tr_sh` { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $OCAMLLIB/cairo/cairo.cma" >&5 $as_echo_n "checking for $OCAMLLIB/cairo/cairo.cma... " >&6; } if { as_var=$as_ac_File; eval "test \"\${$as_var+set}\" = set"; }; then : $as_echo_n "(cached) " >&6 else test "$cross_compiling" = yes && as_fn_error "cannot check for file existence when cross compiling" "$LINENO" 5 if test -r "$OCAMLLIB/cairo/cairo.cma"; then eval "$as_ac_File=yes" else eval "$as_ac_File=no" fi fi eval ac_res=\$$as_ac_File { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } eval as_val=\$$as_ac_File if test "x$as_val" = x""yes; then : CAIRO=yes else CAIRO=no fi if test "$CAIRO" = yes; then CAIROLIB=$OCAMLLIB/cairo/ elif test -n "$OCAMLLIBLOCAL"; then as_ac_File=`$as_echo "ac_cv_file_$OCAMLLIBLOCAL/cairo/cairo.cma" | $as_tr_sh` { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $OCAMLLIBLOCAL/cairo/cairo.cma" >&5 $as_echo_n "checking for $OCAMLLIBLOCAL/cairo/cairo.cma... " >&6; } if { as_var=$as_ac_File; eval "test \"\${$as_var+set}\" = set"; }; then : $as_echo_n "(cached) " >&6 else test "$cross_compiling" = yes && as_fn_error "cannot check for file existence when cross compiling" "$LINENO" 5 if test -r "$OCAMLLIBLOCAL/cairo/cairo.cma"; then eval "$as_ac_File=yes" else eval "$as_ac_File=no" fi fi eval ac_res=\$$as_ac_File { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } eval as_val=\$$as_ac_File if test "x$as_val" = x""yes; then : CAIRO=yes else CAIRO=no fi if test "$CAIRO" = yes; then CAIROLIB=$OCAMLLIBLOCAL/cairo/ fi fi fi fi # Check whether --enable-concrete was given. if test "${enable_concrete+set}" = set; then : enableval=$enable_concrete; else enable_concrete=yes fi BITSTRING=no if test "$enable_concrete" = yes; then if test "$USEOCAMLFIND" = yes; then BITSTRINGLIB=$(ocamlfind query bitstring) fi if test -n "$BITSTRINGLIB";then echo "ocamlfind found bitstring in $BITSTRINGLIB" BITSTRING=yes else as_ac_File=`$as_echo "ac_cv_file_$OCAMLLIB/bitstring/bitstring.cma" | $as_tr_sh` { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $OCAMLLIB/bitstring/bitstring.cma" >&5 $as_echo_n "checking for $OCAMLLIB/bitstring/bitstring.cma... " >&6; } if { as_var=$as_ac_File; eval "test \"\${$as_var+set}\" = set"; }; then : $as_echo_n "(cached) " >&6 else test "$cross_compiling" = yes && as_fn_error "cannot check for file existence when cross compiling" "$LINENO" 5 if test -r "$OCAMLLIB/bitstring/bitstring.cma"; then eval "$as_ac_File=yes" else eval "$as_ac_File=no" fi fi eval ac_res=\$$as_ac_File { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } eval as_val=\$$as_ac_File if test "x$as_val" = x""yes; then : BITSTRING=yes else BITSTRING=no fi if test "$BITSTRING" = yes; then BITSTRINGLIB=$OCAMLLIB/bitstring/ elif test -n "$OCAMLLIBLOCAL"; then as_ac_File=`$as_echo "ac_cv_file_$OCAMLLIBLOCAL/bitstring/bitstring.cma" | $as_tr_sh` { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $OCAMLLIBLOCAL/bitstring/bitstring.cma" >&5 $as_echo_n "checking for $OCAMLLIBLOCAL/bitstring/bitstring.cma... " >&6; } if { as_var=$as_ac_File; eval "test \"\${$as_var+set}\" = set"; }; then : $as_echo_n "(cached) " >&6 else test "$cross_compiling" = yes && as_fn_error "cannot check for file existence when cross compiling" "$LINENO" 5 if test -r "$OCAMLLIBLOCAL/bitstring/bitstring.cma"; then eval "$as_ac_File=yes" else eval "$as_ac_File=no" fi fi eval ac_res=\$$as_ac_File { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } eval as_val=\$$as_ac_File if test "x$as_val" = x""yes; then : BITSTRING=yes else BITSTRING=no fi if test "$BITSTRING" = yes; then BITSTRINGLIB=$OCAMLLIBLOCAL/bitstring/ fi fi 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="" # Check whether --enable-lablgtk was given. if test "${enable_lablgtk+set}" = set; then : enableval=$enable_lablgtk; else enable_lablgtk=yes fi LABLGTK2=no if test "$enable_lablgtk" = yes; then # checking for lablgtk2 if test "$USEOCAMLFIND" == yes; then LABLGTK2LIB=$(ocamlfind query lablgtk2) fi if test -n "$LABLGTK2LIB";then echo "ocamlfind found lablgtk2 in $LABLGTK2LIB" else as_ac_File=`$as_echo "ac_cv_file_$OCAMLLIB/lablgtk2/lablgtk.cma" | $as_tr_sh` { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $OCAMLLIB/lablgtk2/lablgtk.cma" >&5 $as_echo_n "checking for $OCAMLLIB/lablgtk2/lablgtk.cma... " >&6; } if { as_var=$as_ac_File; eval "test \"\${$as_var+set}\" = set"; }; then : $as_echo_n "(cached) " >&6 else test "$cross_compiling" = yes && as_fn_error "cannot check for file existence when cross compiling" "$LINENO" 5 if test -r "$OCAMLLIB/lablgtk2/lablgtk.cma"; then eval "$as_ac_File=yes" else eval "$as_ac_File=no" fi fi eval ac_res=\$$as_ac_File { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } eval as_val=\$$as_ac_File if test "x$as_val" = x""yes; then : LABLGTK2=yes else LABLGTK2=no fi if test "$LABLGTK2" = yes; then LABLGTK2LIB=$OCAMLLIB/lablgtk2/ elif test -n "$OCAMLLIBLOCAL"; then as_ac_File=`$as_echo "ac_cv_file_$OCAMLLIBLOCAL/lablgtk2/lablgtk2.cma" | $as_tr_sh` { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $OCAMLLIBLOCAL/lablgtk2/lablgtk2.cma" >&5 $as_echo_n "checking for $OCAMLLIBLOCAL/lablgtk2/lablgtk2.cma... " >&6; } if { as_var=$as_ac_File; eval "test \"\${$as_var+set}\" = set"; }; then : $as_echo_n "(cached) " >&6 else test "$cross_compiling" = yes && as_fn_error "cannot check for file existence when cross compiling" "$LINENO" 5 if test -r "$OCAMLLIBLOCAL/lablgtk2/lablgtk2.cma"; then eval "$as_ac_File=yes" else eval "$as_ac_File=no" fi fi eval ac_res=\$$as_ac_File { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } eval as_val=\$$as_ac_File if test "x$as_val" = x""yes; then : LABLGTK2=yes else LABLGTK2=no fi if test "$LABLGTK2" = yes; then LABLGTK2LIB=$OCAMLLIBLOCAL/lablgtk2/ fi fi fi fi ##AC_CHECK_FILE($OCAMLLIB/lablgtk2/lablgtk.cma,LABLGTK2=yes,LABLGTK2=no) ## AC_CHECK_PROG(LABLGTK2,lablgtk2,yes,no) not always available (Win32) if test -n "$LABLGTK2LIB" ; then LABLGTK2=yes INCLUDEGTK2="-I +lablgtk2" else LABLGTK2=no fi # checking for cairo.lablgtk2 if test "$USEOCAMLFIND" == yes; then CAIROLABLGTK2LIB=$(ocamlfind query cairo.lablgtk2) fi if test -n "$CAIROLABLGTK2LIB";then echo "ocamlfind found cairo.lablgtk2 in $CAIROLABLGTK2LIB" else as_ac_File=`$as_echo "ac_cv_file_$OCAMLLIB/cairo/cairo_lablgtk.cma" | $as_tr_sh` { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $OCAMLLIB/cairo/cairo_lablgtk.cma" >&5 $as_echo_n "checking for $OCAMLLIB/cairo/cairo_lablgtk.cma... " >&6; } if { as_var=$as_ac_File; eval "test \"\${$as_var+set}\" = set"; }; then : $as_echo_n "(cached) " >&6 else test "$cross_compiling" = yes && as_fn_error "cannot check for file existence when cross compiling" "$LINENO" 5 if test -r "$OCAMLLIB/cairo/cairo_lablgtk.cma"; then eval "$as_ac_File=yes" else eval "$as_ac_File=no" fi fi eval ac_res=\$$as_ac_File { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } eval as_val=\$$as_ac_File if test "x$as_val" = x""yes; then : CAIROLABLGTK2=yes else CAIROLABLGTK2=no fi if test "$CAIROLABLGTK2" = yes; then CAIROLABLGTK2LIB=$OCAMLLIB/lablgtk2/ elif test -n "$OCAMLLIBLOCAL"; then as_ac_File=`$as_echo "ac_cv_file_$OCAMLLIBLOCAL/cairo/cairo_lablgtk.cma" | $as_tr_sh` { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $OCAMLLIBLOCAL/cairo/cairo_lablgtk.cma" >&5 $as_echo_n "checking for $OCAMLLIBLOCAL/cairo/cairo_lablgtk.cma... " >&6; } if { as_var=$as_ac_File; eval "test \"\${$as_var+set}\" = set"; }; then : $as_echo_n "(cached) " >&6 else test "$cross_compiling" = yes && as_fn_error "cannot check for file existence when cross compiling" "$LINENO" 5 if test -r "$OCAMLLIBLOCAL/cairo/cairo_lablgtk.cma"; then eval "$as_ac_File=yes" else eval "$as_ac_File=no" fi fi eval ac_res=\$$as_ac_File { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } eval as_val=\$$as_ac_File if test "x$as_val" = x""yes; then : CAIROLABLGTK2=yes else CAIROLABLGTK2=no fi if test "$CAIROLABLGTK2" = yes; then CAIROLABLGTK2LIB=$OCAMLLIBLOCAL/cairo/ fi fi fi if test -n "$LABLGTK2LIB" ; then CAIROLABLGTK2=yes else CAIROLABLGTK2=no fi #Viewer for ps and pdf for ac_prog in gv evince do # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if test "${ac_cv_prog_PSVIEWER+set}" = set; then : $as_echo_n "(cached) " >&6 else if test -n "$PSVIEWER"; then ac_cv_prog_PSVIEWER="$PSVIEWER" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_prog_PSVIEWER="$ac_prog" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi PSVIEWER=$ac_cv_prog_PSVIEWER if test -n "$PSVIEWER"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $PSVIEWER" >&5 $as_echo "$PSVIEWER" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi test -n "$PSVIEWER" && break done for ac_prog in xpdf acroread evince do # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if test "${ac_cv_prog_PDFVIEWER+set}" = set; then : $as_echo_n "(cached) " >&6 else if test -n "$PDFVIEWER"; then ac_cv_prog_PDFVIEWER="$PDFVIEWER" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_prog_PDFVIEWER="$ac_prog" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi PDFVIEWER=$ac_cv_prog_PDFVIEWER if test -n "$PDFVIEWER"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $PDFVIEWER" >&5 $as_echo "$PDFVIEWER" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi test -n "$PDFVIEWER" && break done # substitutions to perform 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="$ac_config_files META version.ml Makefile myocamlbuild.ml" cat >confcache <<\_ACEOF # This file is a shell script that caches the results of configure # tests run on this system so they can be shared between configure # scripts and configure runs, see configure's option --config-cache. # It is not useful on other systems. If it contains results you don't # want to keep, you may remove or edit it. # # config.status only pays attention to the cache file if you give it # the --recheck option to rerun configure. # # `ac_cv_env_foo' variables (set or unset) will be overridden when # loading this file, other *unset* `ac_cv_foo' will be assigned the # following values. _ACEOF # The following way of writing the cache mishandles newlines in values, # but we know of no workaround that is simple, portable, and efficient. # So, we kill variables containing newlines. # Ultrix sh set writes to stderr and can't be redirected directly, # and sets the high bit in the cache file unless we assign to the vars. ( for ac_var in `(set) 2>&1 | sed -n 's/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'`; do eval ac_val=\$$ac_var case $ac_val in #( *${as_nl}*) case $ac_var in #( *_cv_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 $as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; esac case $ac_var in #( _ | IFS | as_nl) ;; #( BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( *) { eval $ac_var=; unset $ac_var;} ;; esac ;; esac done (set) 2>&1 | case $as_nl`(ac_space=' '; set) 2>&1` in #( *${as_nl}ac_space=\ *) # `set' does not quote correctly, so add quotes: double-quote # substitution turns \\\\ into \\, and sed turns \\ into \. sed -n \ "s/'/'\\\\''/g; s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\\2'/p" ;; #( *) # `set' quotes correctly as required by POSIX, so do not add quotes. sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" ;; esac | sort ) | sed ' /^ac_cv_env_/b end t clear :clear s/^\([^=]*\)=\(.*[{}].*\)$/test "${\1+set}" = set || &/ t end s/^\([^=]*\)=\(.*\)$/\1=${\1=\2}/ :end' >>confcache if diff "$cache_file" confcache >/dev/null 2>&1; then :; else if test -w "$cache_file"; then test "x$cache_file" != "x/dev/null" && { $as_echo "$as_me:${as_lineno-$LINENO}: updating cache $cache_file" >&5 $as_echo "$as_me: updating cache $cache_file" >&6;} cat confcache >$cache_file else { $as_echo "$as_me:${as_lineno-$LINENO}: not updating unwritable cache $cache_file" >&5 $as_echo "$as_me: not updating unwritable cache $cache_file" >&6;} fi fi rm -f confcache test "x$prefix" = xNONE && prefix=$ac_default_prefix # Let make expand exec_prefix. test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' # Transform confdefs.h into DEFS. # Protect against shell expansion while executing Makefile rules. # Protect against Makefile macro expansion. # # If the first sed substitution is executed (which looks for macros that # take arguments), then branch to the quote section. Otherwise, # look for a macro that doesn't take arguments. ac_script=' :mline /\\$/{ N s,\\\n,, b mline } t clear :clear s/^[ ]*#[ ]*define[ ][ ]*\([^ (][^ (]*([^)]*)\)[ ]*\(.*\)/-D\1=\2/g t quote s/^[ ]*#[ ]*define[ ][ ]*\([^ ][^ ]*\)[ ]*\(.*\)/-D\1=\2/g t quote b any :quote s/[ `~#$^&*(){}\\|;'\''"<>?]/\\&/g s/\[/\\&/g s/\]/\\&/g s/\$/$$/g H :any ${ g s/^\n// s/\n/ /g p } ' DEFS=`sed -n "$ac_script" confdefs.h` ac_libobjs= ac_ltlibobjs= for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue # 1. Remove the extension, and $U if already installed. ac_script='s/\$U\././;s/\.o$//;s/\.obj$//' ac_i=`$as_echo "$ac_i" | sed "$ac_script"` # 2. Prepend LIBOBJDIR. When used with automake>=1.10 LIBOBJDIR # will be set to the directory where LIBOBJS objects are built. as_fn_append ac_libobjs " \${LIBOBJDIR}$ac_i\$U.$ac_objext" as_fn_append ac_ltlibobjs " \${LIBOBJDIR}$ac_i"'$U.lo' done LIBOBJS=$ac_libobjs LTLIBOBJS=$ac_ltlibobjs : ${CONFIG_STATUS=./config.status} ac_write_fail=0 ac_clean_files_save=$ac_clean_files ac_clean_files="$ac_clean_files $CONFIG_STATUS" { $as_echo "$as_me:${as_lineno-$LINENO}: creating $CONFIG_STATUS" >&5 $as_echo "$as_me: creating $CONFIG_STATUS" >&6;} as_write_fail=0 cat >$CONFIG_STATUS <<_ASEOF || as_write_fail=1 #! $SHELL # Generated by $as_me. # Run this file to recreate the current configuration. # Compiler output produced by configure, useful for debugging # configure, is in config.log if it exists. debug=false ac_cs_recheck=false ac_cs_silent=false SHELL=\${CONFIG_SHELL-$SHELL} export SHELL _ASEOF cat >>$CONFIG_STATUS <<\_ASEOF || as_write_fail=1 ## -------------------- ## ## M4sh Initialization. ## ## -------------------- ## # Be more Bourne compatible DUALCASE=1; export DUALCASE # for MKS sh if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then : emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' setopt NO_GLOB_SUBST else case `(set -o) 2>/dev/null` in #( *posix*) : set -o posix ;; #( *) : ;; esac fi as_nl=' ' export as_nl # Printing a long string crashes Solaris 7 /usr/bin/printf. as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo # Prefer a ksh shell builtin over an external printf program on Solaris, # but without wasting forks for bash or zsh. if test -z "$BASH_VERSION$ZSH_VERSION" \ && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='print -r --' as_echo_n='print -rn --' elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='printf %s\n' as_echo_n='printf %s' else if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' as_echo_n='/usr/ucb/echo -n' else as_echo_body='eval expr "X$1" : "X\\(.*\\)"' as_echo_n_body='eval arg=$1; case $arg in #( *"$as_nl"*) expr "X$arg" : "X\\(.*\\)$as_nl"; arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; esac; expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" ' export as_echo_n_body as_echo_n='sh -c $as_echo_n_body as_echo' fi export as_echo_body as_echo='sh -c $as_echo_body as_echo' fi # The user is always right. if test "${PATH_SEPARATOR+set}" != set; then PATH_SEPARATOR=: (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || PATH_SEPARATOR=';' } fi # IFS # We need space, tab and new line, in precisely that order. Quoting is # there to prevent editors from complaining about space-tab. # (If _AS_PATH_WALK were called with IFS unset, it would disable word # splitting by setting IFS to empty value.) IFS=" "" $as_nl" # Find who we are. Look in the path if we contain no directory separator. case $0 in #(( *[\\/]* ) as_myself=$0 ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break done IFS=$as_save_IFS ;; esac # We did not find ourselves, most probably we were run as `sh COMMAND' # in which case we are not to be found in the path. if test "x$as_myself" = x; then as_myself=$0 fi if test ! -f "$as_myself"; then $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 exit 1 fi # Unset variables that we do not need and which cause bugs (e.g. in # pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" # suppresses any "Segmentation fault" message there. '((' could # trigger a bug in pdksh 5.2.14. for as_var in BASH_ENV ENV MAIL MAILPATH do eval test x\${$as_var+set} = xset \ && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : done PS1='$ ' PS2='> ' PS4='+ ' # NLS nuisances. LC_ALL=C export LC_ALL LANGUAGE=C export LANGUAGE # CDPATH. (unset CDPATH) >/dev/null 2>&1 && unset CDPATH # as_fn_error ERROR [LINENO LOG_FD] # --------------------------------- # Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are # provided, also output the error to LOG_FD, referencing LINENO. Then exit the # script with status $?, using 1 if that was 0. as_fn_error () { as_status=$?; test $as_status -eq 0 && as_status=1 if test "$3"; then as_lineno=${as_lineno-"$2"} as_lineno_stack=as_lineno_stack=$as_lineno_stack $as_echo "$as_me:${as_lineno-$LINENO}: error: $1" >&$3 fi $as_echo "$as_me: error: $1" >&2 as_fn_exit $as_status } # as_fn_error # as_fn_set_status STATUS # ----------------------- # Set $? to STATUS, without forking. as_fn_set_status () { return $1 } # as_fn_set_status # as_fn_exit STATUS # ----------------- # Exit the shell with STATUS, even in a "trap 0" or "set -e" context. as_fn_exit () { set +e as_fn_set_status $1 exit $1 } # as_fn_exit # as_fn_unset VAR # --------------- # Portably unset VAR. as_fn_unset () { { eval $1=; unset $1;} } as_unset=as_fn_unset # as_fn_append VAR VALUE # ---------------------- # Append the text in VALUE to the end of the definition contained in VAR. Take # advantage of any shell optimizations that allow amortized linear growth over # repeated appends, instead of the typical quadratic growth present in naive # implementations. if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then : eval 'as_fn_append () { eval $1+=\$2 }' else as_fn_append () { eval $1=\$$1\$2 } fi # as_fn_append # as_fn_arith ARG... # ------------------ # Perform arithmetic evaluation on the ARGs, and store the result in the # global $as_val. Take advantage of shells that can avoid forks. The arguments # must be portable across $(()) and expr. if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then : eval 'as_fn_arith () { as_val=$(( $* )) }' else as_fn_arith () { as_val=`expr "$@" || test $? -eq 1` } fi # as_fn_arith if expr a : '\(a\)' >/dev/null 2>&1 && test "X`expr 00001 : '.*\(...\)'`" = X001; then as_expr=expr else as_expr=false fi if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then as_basename=basename else as_basename=false fi if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then as_dirname=dirname else as_dirname=false fi as_me=`$as_basename -- "$0" || $as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ X"$0" : 'X\(//\)$' \| \ X"$0" : 'X\(/\)' \| . 2>/dev/null || $as_echo X/"$0" | sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/ q } /^X\/\(\/\/\)$/{ s//\1/ q } /^X\/\(\/\).*/{ s//\1/ q } s/.*/./; q'` # Avoid depending upon Character Ranges. as_cr_letters='abcdefghijklmnopqrstuvwxyz' as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' as_cr_Letters=$as_cr_letters$as_cr_LETTERS as_cr_digits='0123456789' as_cr_alnum=$as_cr_Letters$as_cr_digits ECHO_C= ECHO_N= ECHO_T= case `echo -n x` in #((((( -n*) case `echo 'xy\c'` in *c*) ECHO_T=' ';; # ECHO_T is single tab character. xy) ECHO_C='\c';; *) echo `echo ksh88 bug on AIX 6.1` > /dev/null ECHO_T=' ';; esac;; *) ECHO_N='-n';; esac rm -f conf$$ conf$$.exe conf$$.file if test -d conf$$.dir; then rm -f conf$$.dir/conf$$.file else rm -f conf$$.dir mkdir conf$$.dir 2>/dev/null fi if (echo >conf$$.file) 2>/dev/null; then if ln -s conf$$.file conf$$ 2>/dev/null; then as_ln_s='ln -s' # ... but there are two gotchas: # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. # In both cases, we have to default to `cp -p'. ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || as_ln_s='cp -p' elif ln conf$$.file conf$$ 2>/dev/null; then as_ln_s=ln else as_ln_s='cp -p' fi else as_ln_s='cp -p' fi rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file rmdir conf$$.dir 2>/dev/null # as_fn_mkdir_p # ------------- # Create "$as_dir" as a directory, including parents if necessary. as_fn_mkdir_p () { case $as_dir in #( -*) as_dir=./$as_dir;; esac test -d "$as_dir" || eval $as_mkdir_p || { as_dirs= while :; do case $as_dir in #( *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( *) as_qdir=$as_dir;; esac as_dirs="'$as_qdir' $as_dirs" as_dir=`$as_dirname -- "$as_dir" || $as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_dir" : 'X\(//\)[^/]' \| \ X"$as_dir" : 'X\(//\)$' \| \ X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$as_dir" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` test -d "$as_dir" && break done test -z "$as_dirs" || eval "mkdir $as_dirs" } || test -d "$as_dir" || as_fn_error "cannot create directory $as_dir" } # as_fn_mkdir_p if mkdir -p . 2>/dev/null; then as_mkdir_p='mkdir -p "$as_dir"' else test -d ./-p && rmdir ./-p as_mkdir_p=false fi if test -x / >/dev/null 2>&1; then as_test_x='test -x' else if ls -dL / >/dev/null 2>&1; then as_ls_L_option=L else as_ls_L_option= fi as_test_x=' eval sh -c '\'' if test -d "$1"; then test -d "$1/."; else case $1 in #( -*)set "./$1";; esac; case `ls -ld'$as_ls_L_option' "$1" 2>/dev/null` in #(( ???[sx]*):;;*)false;;esac;fi '\'' sh ' fi as_executable_p=$as_test_x # Sed expression to map a string onto a valid CPP name. as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" # Sed expression to map a string onto a valid variable name. as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" exec 6>&1 ## ----------------------------------- ## ## Main body of $CONFIG_STATUS script. ## ## ----------------------------------- ## _ASEOF test $as_write_fail = 0 && chmod +x $CONFIG_STATUS || ac_write_fail=1 cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # Save the log message, to keep $0 and so on meaningful, and to # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. ac_log=" This file was extended by mlpost $as_me 0.8.1, which was generated by GNU Autoconf 2.65. Invocation command line was CONFIG_FILES = $CONFIG_FILES CONFIG_HEADERS = $CONFIG_HEADERS CONFIG_LINKS = $CONFIG_LINKS CONFIG_COMMANDS = $CONFIG_COMMANDS $ $0 $@ on `(hostname || uname -n) 2>/dev/null | sed 1q` " _ACEOF case $ac_config_files in *" "*) set x $ac_config_files; shift; ac_config_files=$*;; esac cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 # Files that config.status was made for. config_files="$ac_config_files" _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 ac_cs_usage="\ \`$as_me' instantiates files and other configuration actions from templates according to the current configuration. Unless the files and actions are specified as TAGs, all are instantiated by default. Usage: $0 [OPTION]... [TAG]... -h, --help print this help, then exit -V, --version print version number and configuration settings, then exit --config print configuration, then exit -q, --quiet, --silent do not print progress messages -d, --debug don't remove temporary files --recheck update $as_me by reconfiguring in the same conditions --file=FILE[:TEMPLATE] instantiate the configuration file FILE Configuration files: $config_files Report bugs to the package provider." _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`" ac_cs_version="\\ mlpost config.status 0.8.1 configured by $0, generated by GNU Autoconf 2.65, with options \\"\$ac_cs_config\\" Copyright (C) 2009 Free Software Foundation, Inc. This config.status script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it." ac_pwd='$ac_pwd' srcdir='$srcdir' test -n "\$AWK" || AWK=awk _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # The default lists apply if the user does not specify any file. ac_need_defaults=: while test $# != 0 do case $1 in --*=*) ac_option=`expr "X$1" : 'X\([^=]*\)='` ac_optarg=`expr "X$1" : 'X[^=]*=\(.*\)'` ac_shift=: ;; *) ac_option=$1 ac_optarg=$2 ac_shift=shift ;; esac case $ac_option in # Handling of the options. -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) ac_cs_recheck=: ;; --version | --versio | --versi | --vers | --ver | --ve | --v | -V ) $as_echo "$ac_cs_version"; exit ;; --config | --confi | --conf | --con | --co | --c ) $as_echo "$ac_cs_config"; exit ;; --debug | --debu | --deb | --de | --d | -d ) debug=: ;; --file | --fil | --fi | --f ) $ac_shift case $ac_optarg in *\'*) ac_optarg=`$as_echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;; esac as_fn_append CONFIG_FILES " '$ac_optarg'" ac_need_defaults=false;; --he | --h | --help | --hel | -h ) $as_echo "$ac_cs_usage"; exit ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil | --si | --s) ac_cs_silent=: ;; # This is an error. -*) as_fn_error "unrecognized option: \`$1' Try \`$0 --help' for more information." ;; *) as_fn_append ac_config_targets " $1" ac_need_defaults=false ;; esac shift done ac_configure_extra_args= if $ac_cs_silent; then exec 6>/dev/null ac_configure_extra_args="$ac_configure_extra_args --silent" fi _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 if \$ac_cs_recheck; then set X '$SHELL' '$0' $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion shift \$as_echo "running CONFIG_SHELL=$SHELL \$*" >&6 CONFIG_SHELL='$SHELL' export CONFIG_SHELL exec "\$@" fi _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 exec 5>>config.log { echo sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX ## Running $as_me. ## _ASBOX $as_echo "$ac_log" } >&5 _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # Handling of arguments. for ac_config_target in $ac_config_targets do case $ac_config_target in "META") CONFIG_FILES="$CONFIG_FILES META" ;; "version.ml") CONFIG_FILES="$CONFIG_FILES version.ml" ;; "Makefile") CONFIG_FILES="$CONFIG_FILES Makefile" ;; "myocamlbuild.ml") CONFIG_FILES="$CONFIG_FILES myocamlbuild.ml" ;; *) as_fn_error "invalid argument: \`$ac_config_target'" "$LINENO" 5;; esac done # If the user did not use the arguments to specify the items to instantiate, # then the envvar interface is used. Set only those that are not. # We use the long form for the default assignment because of an extremely # bizarre bug on SunOS 4.1.3. if $ac_need_defaults; then test "${CONFIG_FILES+set}" = set || CONFIG_FILES=$config_files fi # Have a temporary directory for convenience. Make it in the build tree # simply because there is no reason against having it here, and in addition, # creating and moving files from /tmp can sometimes cause problems. # Hook for its removal unless debugging. # Note that there is a small window in which the directory will not be cleaned: # after its creation but before its name has been assigned to `$tmp'. $debug || { tmp= trap 'exit_status=$? { test -z "$tmp" || test ! -d "$tmp" || rm -fr "$tmp"; } && exit $exit_status ' 0 trap 'as_fn_exit 1' 1 2 13 15 } # Create a (secure) tmp directory for tmp files. { tmp=`(umask 077 && mktemp -d "./confXXXXXX") 2>/dev/null` && test -n "$tmp" && test -d "$tmp" } || { tmp=./conf$$-$RANDOM (umask 077 && mkdir "$tmp") } || as_fn_error "cannot create a temporary directory in ." "$LINENO" 5 # Set up the scripts for CONFIG_FILES section. # No need to generate them if there are no CONFIG_FILES. # This happens for instance with `./config.status config.h'. if test -n "$CONFIG_FILES"; then ac_cr=`echo X | tr X '\015'` # On cygwin, bash can eat \r inside `` if the user requested igncr. # But we know of no other shell where ac_cr would be empty at this # point, so we can use a bashism as a fallback. if test "x$ac_cr" = x; then eval ac_cr=\$\'\\r\' fi ac_cs_awk_cr=`$AWK 'BEGIN { print "a\rb" }' /dev/null` if test "$ac_cs_awk_cr" = "a${ac_cr}b"; then ac_cs_awk_cr='\r' else ac_cs_awk_cr=$ac_cr fi echo 'BEGIN {' >"$tmp/subs1.awk" && _ACEOF { echo "cat >conf$$subs.awk <<_ACEOF" && echo "$ac_subst_vars" | sed 's/.*/&!$&$ac_delim/' && echo "_ACEOF" } >conf$$subs.sh || as_fn_error "could not make $CONFIG_STATUS" "$LINENO" 5 ac_delim_num=`echo "$ac_subst_vars" | grep -c '$'` ac_delim='%!_!# ' for ac_last_try in false false false false false :; do . ./conf$$subs.sh || as_fn_error "could not make $CONFIG_STATUS" "$LINENO" 5 ac_delim_n=`sed -n "s/.*$ac_delim\$/X/p" conf$$subs.awk | grep -c X` if test $ac_delim_n = $ac_delim_num; then break elif $ac_last_try; then as_fn_error "could not make $CONFIG_STATUS" "$LINENO" 5 else ac_delim="$ac_delim!$ac_delim _$ac_delim!! " fi done rm -f conf$$subs.sh cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 cat >>"\$tmp/subs1.awk" <<\\_ACAWK && _ACEOF sed -n ' h s/^/S["/; s/!.*/"]=/ p g s/^[^!]*!// :repl t repl s/'"$ac_delim"'$// t delim :nl h s/\(.\{148\}\)..*/\1/ t more1 s/["\\]/\\&/g; s/^/"/; s/$/\\n"\\/ p n b repl :more1 s/["\\]/\\&/g; s/^/"/; s/$/"\\/ p g s/.\{148\}// t nl :delim h s/\(.\{148\}\)..*/\1/ t more2 s/["\\]/\\&/g; s/^/"/; s/$/"/ p b :more2 s/["\\]/\\&/g; s/^/"/; s/$/"\\/ p g s/.\{148\}// t delim ' >$CONFIG_STATUS || ac_write_fail=1 rm -f conf$$subs.awk cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 _ACAWK cat >>"\$tmp/subs1.awk" <<_ACAWK && for (key in S) S_is_set[key] = 1 FS = "" } { line = $ 0 nfields = split(line, field, "@") substed = 0 len = length(field[1]) for (i = 2; i < nfields; i++) { key = field[i] keylen = length(key) if (S_is_set[key]) { value = S[key] line = substr(line, 1, len) "" value "" substr(line, len + keylen + 3) len += length(value) + length(field[++i]) substed = 1 } else len += 1 + keylen } print line } _ACAWK _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 if sed "s/$ac_cr//" < /dev/null > /dev/null 2>&1; then sed "s/$ac_cr\$//; s/$ac_cr/$ac_cs_awk_cr/g" else cat fi < "$tmp/subs1.awk" > "$tmp/subs.awk" \ || as_fn_error "could not setup config files machinery" "$LINENO" 5 _ACEOF # VPATH may cause trouble with some makes, so we remove $(srcdir), # ${srcdir} and @srcdir@ from VPATH if srcdir is ".", strip leading and # trailing colons and then remove the whole line if VPATH becomes empty # (actually we leave an empty line to preserve line numbers). if test "x$srcdir" = x.; then ac_vpsub='/^[ ]*VPATH[ ]*=/{ s/:*\$(srcdir):*/:/ s/:*\${srcdir}:*/:/ s/:*@srcdir@:*/:/ s/^\([^=]*=[ ]*\):*/\1/ s/:*$// s/^[^=]*=[ ]*$// }' fi cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 fi # test -n "$CONFIG_FILES" eval set X " :F $CONFIG_FILES " shift for ac_tag do case $ac_tag in :[FHLC]) ac_mode=$ac_tag; continue;; esac case $ac_mode$ac_tag in :[FHL]*:*);; :L* | :C*:*) as_fn_error "invalid tag \`$ac_tag'" "$LINENO" 5;; :[FH]-) ac_tag=-:-;; :[FH]*) ac_tag=$ac_tag:$ac_tag.in;; esac ac_save_IFS=$IFS IFS=: set x $ac_tag IFS=$ac_save_IFS shift ac_file=$1 shift case $ac_mode in :L) ac_source=$1;; :[FH]) ac_file_inputs= for ac_f do case $ac_f in -) ac_f="$tmp/stdin";; *) # Look for the file first in the build tree, then in the source tree # (if the path is not absolute). The absolute path cannot be DOS-style, # because $ac_f cannot contain `:'. test -f "$ac_f" || case $ac_f in [\\/$]*) false;; *) test -f "$srcdir/$ac_f" && ac_f="$srcdir/$ac_f";; esac || as_fn_error "cannot find input file: \`$ac_f'" "$LINENO" 5;; esac case $ac_f in *\'*) ac_f=`$as_echo "$ac_f" | sed "s/'/'\\\\\\\\''/g"`;; esac as_fn_append ac_file_inputs " '$ac_f'" done # Let's still pretend it is `configure' which instantiates (i.e., don't # use $as_me), people would be surprised to read: # /* config.h. Generated by config.status. */ configure_input='Generated from '` $as_echo "$*" | sed 's|^[^:]*/||;s|:[^:]*/|, |g' `' by configure.' if test x"$ac_file" != x-; then configure_input="$ac_file. $configure_input" { $as_echo "$as_me:${as_lineno-$LINENO}: creating $ac_file" >&5 $as_echo "$as_me: creating $ac_file" >&6;} fi # Neutralize special characters interpreted by sed in replacement strings. case $configure_input in #( *\&* | *\|* | *\\* ) ac_sed_conf_input=`$as_echo "$configure_input" | sed 's/[\\\\&|]/\\\\&/g'`;; #( *) ac_sed_conf_input=$configure_input;; esac case $ac_tag in *:-:* | *:-) cat >"$tmp/stdin" \ || as_fn_error "could not create $ac_file" "$LINENO" 5 ;; esac ;; esac ac_dir=`$as_dirname -- "$ac_file" || $as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$ac_file" : 'X\(//\)[^/]' \| \ X"$ac_file" : 'X\(//\)$' \| \ X"$ac_file" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$ac_file" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` as_dir="$ac_dir"; as_fn_mkdir_p ac_builddir=. case "$ac_dir" in .) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'` # A ".." for each directory in $ac_dir_suffix. ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` case $ac_top_builddir_sub in "") ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; esac ;; esac ac_abs_top_builddir=$ac_pwd ac_abs_builddir=$ac_pwd$ac_dir_suffix # for backward compatibility: ac_top_builddir=$ac_top_build_prefix case $srcdir in .) # We are building in place. ac_srcdir=. ac_top_srcdir=$ac_top_builddir_sub ac_abs_top_srcdir=$ac_pwd ;; [\\/]* | ?:[\\/]* ) # Absolute name. ac_srcdir=$srcdir$ac_dir_suffix; ac_top_srcdir=$srcdir ac_abs_top_srcdir=$srcdir ;; *) # Relative name. ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix ac_top_srcdir=$ac_top_build_prefix$srcdir ac_abs_top_srcdir=$ac_pwd/$srcdir ;; esac ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix case $ac_mode in :F) # # CONFIG_FILE # _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # If the template does not know about datarootdir, expand it. # FIXME: This hack should be removed a few years after 2.60. ac_datarootdir_hack=; ac_datarootdir_seen= ac_sed_dataroot=' /datarootdir/ { p q } /@datadir@/p /@docdir@/p /@infodir@/p /@localedir@/p /@mandir@/p' case `eval "sed -n \"\$ac_sed_dataroot\" $ac_file_inputs"` in *datarootdir*) ac_datarootdir_seen=yes;; *@datadir@*|*@docdir@*|*@infodir@*|*@localedir@*|*@mandir@*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&5 $as_echo "$as_me: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&2;} _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_datarootdir_hack=' s&@datadir@&$datadir&g s&@docdir@&$docdir&g s&@infodir@&$infodir&g s&@localedir@&$localedir&g s&@mandir@&$mandir&g s&\\\${datarootdir}&$datarootdir&g' ;; esac _ACEOF # Neutralize VPATH when `$srcdir' = `.'. # Shell code in configure.ac might set extrasub. # FIXME: do we really want to maintain this feature? cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_sed_extra="$ac_vpsub $extrasub _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 :t /@[a-zA-Z_][a-zA-Z_0-9]*@/!b s|@configure_input@|$ac_sed_conf_input|;t t s&@top_builddir@&$ac_top_builddir_sub&;t t s&@top_build_prefix@&$ac_top_build_prefix&;t t s&@srcdir@&$ac_srcdir&;t t s&@abs_srcdir@&$ac_abs_srcdir&;t t s&@top_srcdir@&$ac_top_srcdir&;t t s&@abs_top_srcdir@&$ac_abs_top_srcdir&;t t s&@builddir@&$ac_builddir&;t t s&@abs_builddir@&$ac_abs_builddir&;t t s&@abs_top_builddir@&$ac_abs_top_builddir&;t t $ac_datarootdir_hack " eval sed \"\$ac_sed_extra\" "$ac_file_inputs" | $AWK -f "$tmp/subs.awk" >$tmp/out \ || as_fn_error "could not create $ac_file" "$LINENO" 5 test -z "$ac_datarootdir_hack$ac_datarootdir_seen" && { ac_out=`sed -n '/\${datarootdir}/p' "$tmp/out"`; test -n "$ac_out"; } && { ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' "$tmp/out"`; test -z "$ac_out"; } && { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file contains a reference to the variable \`datarootdir' which seems to be undefined. Please make sure it is defined." >&5 $as_echo "$as_me: WARNING: $ac_file contains a reference to the variable \`datarootdir' which seems to be undefined. Please make sure it is defined." >&2;} rm -f "$tmp/stdin" case $ac_file in -) cat "$tmp/out" && rm -f "$tmp/out";; *) rm -f "$ac_file" && mv "$tmp/out" "$ac_file";; esac \ || as_fn_error "could not create $ac_file" "$LINENO" 5 ;; esac done # for ac_tag as_fn_exit 0 _ACEOF ac_clean_files=$ac_clean_files_save test $ac_write_fail = 0 || as_fn_error "write failure creating $CONFIG_STATUS" "$LINENO" 5 # configure is writing to config.log, and then calls config.status. # config.status does its own redirection, appending to config.log. # Unfortunately, on DOS this fails, as config.log is still kept open # by configure, so config.status won't be able to write to it; its # output is simply discarded. So we exec the FD to /dev/null, # effectively closing config.log, so it can be properly (re)opened and # appended to by config.status. When coming back to configure, we # need to make the FD available again. if test "$no_create" != yes; then ac_cs_success=: ac_config_status_args= test "$silent" = yes && ac_config_status_args="$ac_config_status_args --quiet" exec 5>/dev/null $SHELL $CONFIG_STATUS $ac_config_status_args || ac_cs_success=false exec 5>>config.log # Use ||, not &&, to avoid exiting from the if with $? = 1, which # would make configure fail if this is the last instruction. $ac_cs_success || as_fn_exit $? fi if test -n "$ac_unrecognized_opts" && test "$enable_option_checking" != no; then { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: unrecognized options: $ac_unrecognized_opts" >&5 $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2;} fi chmod a-w Makefile chmod a-w myocamlbuild.ml chmod a-w META chmod a-w version.ml mlpost-0.8.1/myocamlmacroparser.mll0000644000443600002640000000675611365367177016645 0ustar kanigdemons(**************************************************************************) (* *) (* 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 an implementation of a macro preprocessor compatible with the * Camlp4Macroparser. *) (* it currently only supports IFDEF statements: IFDEF THEN [ ELSE ] (END | ENDIF) *) { let b = Buffer.create 1024 let symbol_table : (string, unit) Hashtbl.t = Hashtbl.create 17 let char = Buffer.add_char b let def = Hashtbl.mem symbol_table let add_symbol s = Hashtbl.add symbol_table s () let linenr = ref 0 let newline () = incr linenr let ksprintf k s = let buf = Buffer.create 1024 in let fmt = Format.formatter_of_buffer buf in Format.kfprintf (fun _ -> Format.pp_print_flush fmt (); k (Buffer.contents buf)) fmt s let error s = ksprintf (fun s -> Format.eprintf "parse error on line %d: %s" !linenr s; (exit 1 : unit)) s let fn = ref None let args = [ "-D", Arg.String add_symbol, " mark as defined" ] let usage = "Usage: myocamlmacroparser inputfile" let _ = Arg.parse args (fun s -> fn := Some s) usage } let alpha = [ 'A' - 'Z' 'a' - 'z' '0' - '9' ] let other = ( alpha | '_') let endif = "END" | "ENDIF" let blank = [ ' ' '\t' '\n' ] let uident = alpha other* rule normal = parse | "IFDEF" blank* (uident as id) blank* "THEN" { (if def id then thenbranch lexbuf else skiptoelse lexbuf : unit) } | ("ELSE" | "THEN" | endif as s) { error "unexpected token: %s" s } | eof { () } | _ as c { char c ; normal lexbuf } and thenbranch = parse | "ELSE" { skiptoend lexbuf } | endif { normal lexbuf } | ("THEN" as s) { error "unexpected token: %s" s } | eof { error "unexpected end of file" } | _ as c { char c; thenbranch lexbuf } and skiptoelse = parse | "ELSE" { elsebranch lexbuf } | endif { normal lexbuf } | eof { error "unexpected end of file" } | _ { skiptoelse lexbuf } and skiptoend = parse | endif { normal lexbuf } | eof { error "unexpected end of file" } | _ { skiptoend lexbuf } and elsebranch = parse | endif { normal lexbuf } | ("ELSE" | "THEN" as s) { error "unexpected token: %s" s } | eof { error "unexpected end of file" } | _ as c { char c; elsebranch lexbuf } { let _ = let cin = match !fn with | None -> stdin | Some s -> open_in s in normal (Lexing.from_channel cin); close_in cin; Buffer.output_buffer stdout b } mlpost-0.8.1/tree_adv.ml0000644000443600002640000001210611365367177014344 0ustar kanigdemons(**************************************************************************) (* *) (* 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 'a t = Node of 'a * 'a t list let rec map f (Node (x,l)) = Node (f x, List.map (map f) l) let rec map2 f (Node (x,l1)) (Node (y,l2)) = Node (f x y, List.map2 (map2 f) l1 l2) let rec combine (Node (x,l1)) (Node (y,l2)) = Node ((x,y), List.map2 combine l1 l2) let rec split (Node ((x,y),l)) = let l1,l2 = List.split (List.map split l) in Node (x,l1), Node (y,l2) let rec fold f acc (Node (x,l)) = let acc = List.fold_left (fold f) acc l in f acc x let filter_option f t = let rec aux (Node (x,l)) = match f x with | None -> None | Some x -> let l = List.map aux l in let l = List.filter (function None -> false | Some _ -> true) l in let l = List.map (function None -> assert false | Some x -> x) l in Some (Node (x,l)) in match aux t with | None -> invalid_arg "Tree_adv.filter" | Some x -> x let filter f t = filter_option (fun a -> if f a then None else Some a) t let root_map f t = let rec aux r (Node (x,l)) = Node (f r x, List.map (aux (Some x)) l) in aux None t let map_children f t = let rec aux (Node (x,l)) = let child = List.map (function Node (x,_) -> x) l in Node (f x child, List.map aux l) in aux t module Place (X : Signature.Boxlike) = struct let gen_place ~place t = let box_from_a z = Box.empty ~width:(X.width z) ~height:(X.height z) () in let box_tree = map box_from_a t in let b = place box_tree in map2 (fun z e -> X.set_pos (Box.ctr (Box.sub e b)) z) t box_tree let place ?(cs=Num.bp 5.) ?(ls=Num.bp 12.) ?(valign=`Center) ?(halign=`North) t = let rec aux (Node (x,l)) = let l = Box.hbox ~padding:cs ~pos:halign (List.map aux l) in Box.vbox ~padding:ls ~pos:valign [x;l] in aux t let place ?ls ?cs ?valign ?halign t = gen_place ~place:(place ?ls ?cs ?valign ?halign) t end open Command let draw to_box t = fold (fun acc x -> acc ++ Box.draw (to_box x)) Command.nop t let gen_draw_arrows default ~style ~corner t = root_map (fun a b -> match a with | None -> default | Some a -> style (corner `South a) (corner `North b)) t let wrap_whs_box give_box mod_box f = let width a = Box.width (give_box a) in let height a = Box.height (give_box a) in let set_pos p a = mod_box a (Box.center p (give_box a)) in f ~width ~height ~set_pos let wrap_corner_box give_box f = let corner p a = Box.corner p (give_box a) in f ~corner module Overlays = struct type interval = | Bet of int * int (** [|a,b|] *) | Bef of int (** ]|-oo,a|] *) | Aft of int (** [|a,+oo|[ *) | Nev (** emptyset *) | Alw (** N *) let in_interval i = function | Bet (x,y) when x<=i && i<=y -> true | Bef x when i<=x -> true | Aft x when x<=i -> true | Alw -> true | _ -> false let min_interval n = function | Bet (a,_) -> min a n | Bef a -> min a n | Aft a -> min a n | _ -> n let max_interval n = function | Bet (_,b) -> max b n | Bef b -> max b n | Aft b -> max b n | _ -> n let min_tree to_interval t = let f n a = min_interval n (to_interval a) in fold f max_int t let max_tree to_interval t = let f n a = max_interval n (to_interval a) in fold f min_int t type 'a spec = (interval * 'a) list let rec assoq n = function | [] -> raise Not_found | (i,a)::l when in_interval n i -> a | _::l -> assoq n l let max to_num = function | [] -> invalid_arg "Tree_adv.Overlays.width" | (_,a)::l -> List.fold_left (fun w (_,p) -> Num.maxn w (to_num p)) (to_num a) l let set_pos sp pos = List.map (fun (i,b) -> i,sp pos b) end module Overlays_Boxlike (X : Signature.Boxlike) : Signature.Boxlike with type t = X.t Overlays.spec = struct open Overlays type t = X.t spec let width = max X.width let height = max X.height let set_pos = set_pos X.set_pos end mlpost-0.8.1/color.ml0000644000443600002640000013563111365367177013702 0ustar kanigdemons(**************************************************************************) (* *) (* 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.1/contrib/0000755000443600002640000000000011365367167013660 5ustar kanigdemonsmlpost-0.8.1/contrib/lablgtk/0000755000443600002640000000000011365367167015300 5ustar kanigdemonsmlpost-0.8.1/contrib/lablgtk/mlpost_lablgtk.ml0000644000443600002640000001455411365367177020662 0ustar kanigdemons (* 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.1/contrib/lablgtk/META0000644000443600002640000000033611365367177015754 0ustar kanigdemonsdescription = "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.1/contrib/lablgtk/mlpost_lablgtk.mli0000644000443600002640000000570511365367177021031 0ustar kanigdemons(** 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 (** widget gtk to display one 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.1/contrib/dot/0000755000443600002640000000000011365367167014446 5ustar kanigdemonsmlpost-0.8.1/contrib/dot/mlpost_dot.mli0000644000443600002640000000165211365367177017342 0ustar kanigdemons(** 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.1/contrib/dot/xdot_lexer.mll0000644000443600002640000001173511365367177017341 0ustar kanigdemons{ 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.1/contrib/dot/mlpost_dot.mlpack0000644000443600002640000000003211365367177020017 0ustar kanigdemonsXdot_parser Xdot_lexer Dotmlpost-0.8.1/contrib/dot/META0000644000443600002640000000026511365367177015123 0ustar kanigdemonsdescription = "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.1/contrib/dot/xdot_ast.mli0000644000443600002640000000062311365367177017000 0ustar kanigdemonstype 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.1/contrib/dot/dot.mli0000644000443600002640000000050011365367177015733 0ustar kanigdemonsopen 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.1/contrib/dot/_tags0000644000443600002640000000006611365367177015471 0ustar kanigdemons<*.cmx> and not : for-pack(Mlpost_dot)mlpost-0.8.1/contrib/dot/dot.ml0000644000443600002640000001017711365367177015575 0ustar kanigdemonsopen 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 cadd,compute = Concrete.compute_nums () in List.iter (fun n -> cadd (B.width n.fig);cadd (B.height n.fig)) nodes; compute (); 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.1/contrib/dot/Makefile0000644000443600002640000000062111365367177016106 0ustar kanigdemonsBUILD=_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) -cleanmlpost-0.8.1/contrib/dot/xdot_parser.mly0000644000443600002640000000250511365367177017526 0ustar kanigdemons%{ 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.1/gui/0000755000443600002640000000000011365367167013004 5ustar kanigdemonsmlpost-0.8.1/gui/glexer.mll0000644000443600002640000000377111365367177015011 0ustar kanigdemons { open Format type dimension = | Pt | Cm | Mm | Bp | Inch type value = float * dimension type elt = | Num of string * value | Point of string * value * value let elements = ref [] let add_elt e = elements := e :: !elements let dim_of_string = function | "pt" -> Pt | "bp" -> Bp | "cm" -> Cm | "mm" -> Mm | "inch" -> Inch | _ -> assert false } let space = [' ' '\t' '\n' '\r'] let number = '-'? ['0'-'9']+ '.' ['0'-'9']* | '-'? ['0'-'9']* '.' ['0'-'9']+ let dimension = "pt" | "bp" | "cm" | "mm" | "inch" let string = '"' [^ '"']* '"' rule read = parse | '#' [^ '\n']* '\n' { read lexbuf } | "num" space* (string as s) space* (number as n) space* (dimension as d) { let s = String.sub s 1 ((String.length s )-2) in eprintf "Glexer: s=%s n='%s'@." s n; add_elt (Num (s, (float_of_string n, dim_of_string d))); read lexbuf } | "point" space* (string as s) space* (number as n1) space* (dimension as d1) space* ',' space* (number as n2) space* (dimension as d2) {let s = String.sub s 1 ((String.length s )-2) in add_elt (Point (s, (float_of_string n1, dim_of_string d1), (float_of_string n2, dim_of_string d2))); read lexbuf } | _ { read lexbuf } | eof { () } { let read_file f = eprintf "****read_file****@."; let c = open_in f in let lb = Lexing.from_channel c in elements := []; read lb; close_in c; List.rev !elements let string_of_dim = function | Pt -> "pt" | Bp -> "bp" | Cm -> "cm" | Mm -> "mm" | Inch -> "inch" let print_value fmt (f, d) = fprintf fmt "%f %s" f (string_of_dim d) let write_file f el = let c = open_out f in let fmt = formatter_of_out_channel c in let write = function | Num (s, v) -> fprintf fmt "num \"%s\" %a@." s print_value v | Point (s, v1, v2) -> fprintf fmt "point \"%s\" %a, %a@." s print_value v1 print_value v2 in List.iter write el; fprintf fmt "@."; close_out c } mlpost-0.8.1/gui/gmlpost.ml0000644000443600002640000002354611365367177015036 0ustar kanigdemonsopen GMain open GdkKeysyms open Glexer open Format let () = ignore (GtkMain.Main.init ()) let usage () = eprintf "usage: gmlpost file.ml fig-name@."; exit 1 let ml_file, fig_name = if Array.length Sys.argv <> 3 then usage (); let f = Sys.argv.(1) in if not (Sys.file_exists f && Filename.check_suffix f ".ml") then usage (); f, Sys.argv.(2) (* run the mlpost file and create PNG image *) let sys_command cmd = let c = Sys.command cmd in eprintf "%s@." cmd; if c <> 0 then begin eprintf "command '%s' failed with exit code %d@." cmd c; exit 1 end (* size parameters *) let xmin = ref (-1.) let xmax = ref (1.) let ymin = ref (-1.) let ymax = ref (1.) let dx = ref 2. let dy = ref 2. let pic_w = ref 1. let pic_h = ref 1. let set_bbox xmi ymi xma yma = xmin := xmi; xmax := xma; ymin := ymi; ymax := yma; dx := !xmax -. !xmin; dy := !ymax -. !ymin let update_bbox () = let file = fig_name ^ ".1" in let c = open_in file in try while true do let s = input_line c in try Scanf.sscanf s "%%%%HiResBoundingBox: %f %f %f %f" (fun a b c d -> set_bbox a b c d; raise Exit) with Scanf.Scan_failure _ -> () done with | End_of_file -> eprintf "warning: could not find the bounding box in %s @." file; close_in c | Exit -> close_in c let png_file = fig_name ^ ".png" let make_png () = let dvi_file = fig_name^".dvi" in let ps_file = fig_name^".ps" in sys_command ("mlpost -ps -ccopt glexer.cmo " ^ ml_file); sys_command ("latex "^fig_name^" > /dev/null"); sys_command ("dvips -E "^dvi_file^" > /dev/null"); sys_command ("convert "^ps_file^" "^png_file^" > /dev/null"); update_bbox () let () = make_png () let edit_file = Filename.chop_suffix ml_file ".ml" ^ ".edit" let elements = Glexer.read_file edit_file let pointstable = Hashtbl.create 17 let rec init_table = function |[],_,_|_,[],_|_,_,[]|Point _::_ ,_::[],_-> () | Num _::r,_::sps,ps -> init_table (r,sps,ps) | Point (s,(_,d1),(_,d2))::r,sp1::sp2::sps,p::ps -> Hashtbl.add pointstable s ((sp1,d1,sp2,d2),p) ; init_table (r,sps,ps) let spins = ref [] let points = ref [] let z = ref 1. let belong x y = (x>0. && x< !pic_w && y>0. && y< !pic_h) (*------------------------------------------------------------------------*) let rec go_string fmt = function |[],_|_,[]|Point _::_,_::[] -> () | Num (s,(_,d))::r,sp::sps -> let n = sp#value in fprintf fmt "num \"%s\" %f %s \n" s n (string_of_dim d); go_string fmt (r,sps) | Point (s,(_,d1),(_,d2))::r,sp1::sp2::sps -> let n1 = sp1#value in let n2 = sp2#value in fprintf fmt "point \"%s\" %f %s , %f %s \n" s n1 (string_of_dim d1) n2 (string_of_dim d2); go_string fmt (r,sps) let write_edit ()= let f = open_out edit_file in let fmt = formatter_of_out_channel f in go_string fmt (elements,!spins); fprintf fmt "@?"; close_out f let bp_of_dim n = function |Bp -> n |Pt -> n *. 0.99626 |Cm -> n *. 28.34645 |Mm -> n *. 2.83464 |Inch -> n *. 72. let dim_of_bp n = function |Bp -> n |Pt -> n /. 0.99626 |Cm -> n /. 28.34645 |Mm -> n /. 2.83464 |Inch -> n /. 72. let update_points _ ((sp1,d1,sp2,d2),p) = let v1 = bp_of_dim sp1#value d1 in let v2 = bp_of_dim sp2#value d2 in let x = (v1 -. !xmin) *. !pic_w /. !dx in let y = (!ymax -. v2) *. !pic_h /. !dy in p#set [ `X1 (x -. 3.) ; `Y1 (y -. 3.) ; `X2 (x +. 3.) ; `Y2 (y +. 3.) ]; () let refresh canvas pic () = eprintf "@.------------------------------refresh------------------------------@."; write_edit (); make_png (); let pixbuf = GdkPixbuf.from_file png_file in pic#set [`PIXBUF pixbuf]; pic_w := float_of_int (GdkPixbuf.get_width pixbuf); pic_h := float_of_int (GdkPixbuf.get_height pixbuf); (*mise a l'echelle de tous les points au cas ou il y aurait un changement de bbox*) Hashtbl.iter update_points pointstable; eprintf "refresh:@."; eprintf " xmin = %f@." !xmin; eprintf " xmax = %f@." !xmax; eprintf " ymin = %f@." !ymin; eprintf " ymax = %f@." !ymax; eprintf " png = %f x %f pixels@." !pic_w !pic_h; () (*------------------------------------------------------------------------*) let highlight_point item ev = begin match ev with | `ENTER_NOTIFY _ -> item#set [ `FILL_COLOR "red" ] | `LEAVE_NOTIFY ev -> let state = GdkEvent.Crossing.state ev in if not (Gdk.Convert.test_modifier `BUTTON1 state) then item#set [`FILL_COLOR "black" ] | `BUTTON_PRESS ev -> let curs = Gdk.Cursor.create `FLEUR in item#grab [`POINTER_MOTION; `BUTTON_RELEASE] curs (GdkEvent.Button.time ev) | `BUTTON_RELEASE ev -> item#ungrab (GdkEvent.Button.time ev) | _ -> () end ; false let move_point x y s item ev = begin match ev with | `MOTION_NOTIFY ev -> let state = GdkEvent.Motion.state ev in let x = GdkEvent.Motion.x ev in let y = GdkEvent.Motion.y ev in if Gdk.Convert.test_modifier `BUTTON1 state && (belong x y) then begin let (sp1,d1,sp2,d2),_ = Hashtbl.find pointstable s in let x = dim_of_bp x d1 in let y = dim_of_bp y d2 in sp1#set_value (!xmin+.(x*. !dx/. !pic_w)); sp2#set_value (!ymax-.(y*. !dy/. !pic_h)); item#set [ `X1 (x -. 3.) ; `Y1 (y -. 3.) ; `X2 (x +. 3.) ; `Y2 (y +. 3.) ] end | `BUTTON_RELEASE ev -> eprintf "toto@."; | _ -> () end ; false let draw_point root s n1 n2 d1 d2 = let v1 = bp_of_dim n1 d1 in let v2 = bp_of_dim n2 d2 in let x = (v1 -. !xmin) *. !pic_w /. !dx in let y = (!ymax -. v2) *. !pic_h /. !dy in let point = GnoCanvas.ellipse ~x1:(x-.3.) ~x2:(x+.3.) ~y1:(y-.3.) ~y2:(y+.3.) ~props:[ `FILL_COLOR "black" ; `OUTLINE_COLOR "black" ; `WIDTH_PIXELS 0 ] root in let sigs = point#connect in ignore( sigs#event (highlight_point point) ); sigs#event (move_point x y s point); points := point::!points; () (*------------------------------------------------------------------------*) let point_of_spin s sb () = let n = sb#value in try let (sb1,d1,_,d2),p = Hashtbl.find pointstable s in if (sb == sb1) then begin let v = bp_of_dim n d1 in let n = (v -. !xmin) *. !pic_w /. !dx in p#set [ `X1 (n -. 3.) ; `X2 (n +. 3.) ] end else begin let v = bp_of_dim n d2 in let n = (!ymax -. v) *. !pic_h /. !dy in p#set [ `Y1 (n -. 3.) ; `Y2 (n +. 3.) ] end with Not_found -> () let init_spin_bounds = function |Bp -> (-150.),150.,0.5 |Pt -> (-150.),150.,0.5 |Cm -> (-50.),50.,0.1 |Mm -> (-500.),500.,1. |Inch -> (-3.),3.,0.05 let left_part_lign pic vbox vbox2 vbox3 s n d s' = GMisc.label ~text:(s^s') ~packing:vbox#add (); GMisc.label ~text:(string_of_dim d) ~packing:vbox3#add (); let sb = GEdit.spin_button ~packing:vbox2#add ~digits:2 ~numeric:true ~wrap:true () in let lower,upper,step_incr = init_spin_bounds d in sb#adjustment#set_bounds ~lower ~upper ~step_incr (); sb#set_value n; sb#adjustment#connect#value_changed ~callback:(point_of_spin s sb); spins := sb::!spins; () let left_part pic vbox vbox2 vbox3 root = function | Num (s,(n,d)) -> left_part_lign pic vbox vbox2 vbox3 s n d " :" | Point (s,(n1,d1),(n2,d2)) -> left_part_lign pic vbox vbox2 vbox3 s n1 d1 " xpart :" ; left_part_lign pic vbox vbox2 vbox3 s n2 d2 " ypart :" ; draw_point root s n1 n2 d1 d2 let zoom canvas zoo = z:= zoo; canvas#set_pixels_per_unit !z (*------------------------------------------------------------------------*) (* *) let main () = let window = GWindow.window ~title:"GMLPost" () in let vb = GPack.vbox ~spacing:10 ~packing:window#add () in (* Menu bar *) let menubar = GMenu.menu_bar ~packing:vb#pack () in window#connect#destroy ~callback:write_edit ; window#connect#destroy ~callback:Main.quit ; let hbox = GPack.hbox ~spacing:10 ~packing:vb#add () in let scrolled_window = GBin.scrolled_window ~width:350 ~border_width: 10 ~hpolicy: `AUTOMATIC ~packing: hbox#add () in let hbox2 = GPack.hbox ~spacing:10 ~packing:scrolled_window#add_with_viewport () in (* Partie Canvas *) let pixbuf = GdkPixbuf.from_file png_file in pic_w := float_of_int (GdkPixbuf.get_width pixbuf); pic_h := float_of_int (GdkPixbuf.get_height pixbuf); let scrolled_canvas = GBin.scrolled_window ~width:500 ~height:500 ~border_width: 10 ~hpolicy: `AUTOMATIC ~packing:hbox#add () in let canvas = GnoCanvas.canvas ~width:(int_of_float (!pic_w)) ~height:(int_of_float (!pic_h)) ~packing:scrolled_canvas#add_with_viewport () in canvas#set_scroll_region 0. 0. !pic_w !pic_h ; let root = canvas#root in let pic = GnoCanvas.pixbuf root ~pixbuf in let factory = new GMenu.factory menubar in let accel_group = factory#accel_group in let file_menu = factory#add_submenu "File" in let zoom_menu = factory#add_submenu "Zoom" in (* File menu *) let factory = new GMenu.factory file_menu ~accel_group in factory#add_item "Refresh" ~key:_r ~callback: (refresh canvas pic); let factory = new GMenu.factory file_menu ~accel_group in factory#add_item "Quit" ~key:_Q ~callback: Main.quit; (* Zoom *) let factory = new GMenu.factory zoom_menu ~accel_group in factory#add_item "50%" ~callback:(fun()->zoom canvas 0.5); factory#add_item "75%" ~callback:(fun()->zoom canvas 0.75); factory#add_item "100%" ~callback:(fun()->zoom canvas 1.); factory#add_item "125%" ~callback:(fun()->zoom canvas 1.25); factory#add_item "150%" ~callback:(fun()->zoom canvas 1.5); window#add_accel_group accel_group; let vbox = GPack.vbox ~spacing:10 ~packing:hbox2#add () in let vbox2 = GPack.vbox ~spacing:10 ~packing:hbox2#add () in let vbox3 = GPack.vbox ~spacing:10 ~packing:hbox2#add () in List.iter (left_part pic vbox vbox2 vbox3 root) elements; spins := List.rev !spins; points := List.rev !points; init_table (elements,!spins,!points); window#show (); Main.main (); ;; main () mlpost-0.8.1/gui/fig.ml0000644000443600002640000000407211365367177014107 0ustar kanigdemonsopen Mlpost open Num open Path open Command module Edit = struct open Glexer let file = "fig.edit" let elements = ref [] let table = Hashtbl.create 17 let () = if Sys.file_exists file then begin elements := Glexer.read_file file; let add = function | Num (s,_) | Point (s,_,_) as e -> Hashtbl.add table s e in List.iter add !elements end let mk_num = function | Pt -> Num.pt | Cm -> Num.cm | Mm -> Num.mm | Bp -> Num.bp | Inch -> Num.inch let num s v dimension = try match Hashtbl.find table s with | Num (_, (f, dim)) -> mk_num dim f | Point _ -> invalid_arg ("already a point of name " ^ s) with Not_found -> let e = Num (s, (v, dimension)) in elements := e :: !elements; Hashtbl.add table s e; mk_num dimension v let point s v1 dim1 v2 dim2 = try match Hashtbl.find table s with | Num _ -> invalid_arg ("already a num of name " ^ s) | Point (_,(n1,d1),(n2,d2)) -> Point.pt (mk_num d1 n1,mk_num d2 n2) with Not_found -> let e = Point (s, (v1,dim1), (v2,dim2)) in elements := e :: !elements; Hashtbl.add table s e; Point.pt(mk_num dim1 v1,mk_num dim2 v2) let () = at_exit (fun () -> Glexer.write_file file !elements) end (* Exemple d'utilisation de Gmlpost *) open Color (* un histogramme *) let fill = [lightblue; lightgreen; lightyellow; lightred] (* le padding est une valeur éditable *) let padding = Edit.num "padding" 5. Glexer.Bp let hist = Hist.simple ~width:(bp 50.) ~height:(bp 100.) ~fill ~padding [1.;2.;3.;4.] (* et sa légende *) let leg = Legend.legend [lightblue, "2006"; lightgreen, "2007"; lightyellow, "2008"; lightred, "2009"] (* la légende est positionnée au point p1 qui est éditable *) let p1 = Edit.point "legend" 100. Glexer.Bp 100. Glexer.Bp let pic = Command.draw_pic (Picture.shift p1 (Picture.scale (bp 0.5) leg)) (* la figure est l'ensemble de l'histogramme et de sa légende *) let example = hist++pic let () = Metapost.emit "example" example mlpost-0.8.1/gui/_tags0000644000443600002640000000010511365367177014021 0ustar kanigdemons : pkg_lablgtk2, use_unix, use_thread, pkg_lablgnomecanvasmlpost-0.8.1/pen.ml0000644000443600002640000000321311365367177013334 0ustar kanigdemons(**************************************************************************) (* *) (* 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 Transform type t = Types.pen let transform tr p = List.fold_left mkPenTransformed p tr let default = mkPenTransformed mkPenCircle (scaled (mkF 0.5)) let circle = mkPenCircle let square = mkPenSquare let from_path p = mkPenFromPath p let scale f p = transform [Transform.scaled f] p let rotate f p = transform [Transform.rotated f] p let shift pt path = transform [Transform.shifted pt] path let yscale n p = transform [Transform.yscaled n] p let xscale n p = transform [Transform.xscaled n] p mlpost-0.8.1/CHANGES0000644000443600002640000001357011365367177013222 0ustar kanigdemonso - changes in behaviour, new features, bugfixes * - incompatible changes in the interface 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.1/testbox.ml0000644000443600002640000001050411365367177014243 0ustar kanigdemons(**************************************************************************) (* *) (* 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 open Box let f0 = let b = box ~style:Patatoid (box ~style:Circle (box ~style:Ellipse (box (tex "aBc")))) in [draw ~debug:false b] let f1 = let b = hbox ~padding:(bp 20.) [vbox ~padding:(bp 4.) ~pos:`Right [tex "A"; tex ~name:"bc" "BC"; tex "D"]; vbox ~padding:(bp 4.) ~pos:`Left [tex ~name:"e" "E"; tex "FGH"]] in [draw ~debug:false b; box_arrow (get "bc" b) (get "e" b)] let f2 = let tex = tex ~style:Circle in let b = vbox [tex "a"; hbox [tex ~name:"b" "b"; tex "c"]] in let f = hbox ~padding:(bp 20.) [b;b;b] in let arrow = box_arrow ~outd:(vec (dir (-60.))) in let node i = get "b" (nth i f) in [draw ~debug:false f; arrow (node 0) (node 1); arrow (node 1) (node 2)] let f3 = let b = tabularl ~hpadding:(bp 10.) ~vpadding:(bp 20.) ~pos:`Left [[tex "a"; tex "BB"; tex ~name:"dst" "C"]; [tex ~name:"src" "ddd"; tex "\\tiny e"; tex "tagada"]] in [draw ~debug:true b;] let f4 = let tex = tex ~stroke:None in let b = vblock ~pos:`Center [tex "a"; tex "b"; tex "c"] in [draw b] let f5 = let sz = Num.cm 1. in let empty = empty ~width:sz ~height:sz () in let black = set_fill (Color.gray 0.3) empty in let num n = tex ~stroke:None (string_of_int n) in let f i j = if i = 0 && j = 0 then black else num ((i+j)*(i+j)) (* if (i+j) mod 2 =0 then black else white in *) in [draw (gridi 7 3 f)] (** pour comparaison avec f5 *) let f6 = let sz = Num.cm 1. in let empty = empty ~width:sz ~height:sz () in let black = set_fill (Color.gray 0.3) empty in let num n = tex ~stroke:None (string_of_int n) in let f i j = if i = 0 && j = 0 then black else num ((i+j)*(i+j)) (* if (i+j) mod 2 =0 then black else white in *) in [draw (tabulari 7 3 f)] let sudoku = let sq33 cell = gridi 3 3 cell in let sz= Num.cm 0.5 in let empty_cell = empty ~width:sz ~height:sz () in let num n = tex ~stroke:None (string_of_int n) in let cell i j = if Random.bool () then empty_cell else num ((Random.int 9) + 1) in let pen = Pen.scale (Num.bp 1.) (Pen.circle ()) in let square () = set_stroke Color.black (set_pen pen (sq33 cell)) in [draw (sq33 (fun _ _ -> square ()))] let figs = [ f6; f5; sudoku; f4; f3; f0; f1; f2; ] 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/testbox.mp" figs; Misc.write_to_formatted_file "test/testbox.tex" (fun fmt -> fprintf fmt "\\documentclass[a4paper]{article}@."; fprintf fmt "\\usepackage[T1]{fontenc}@."; fprintf fmt "\\usepackage{times}@."; fprintf fmt "\\usepackage[]{graphicx}@."; fprintf fmt "@[\\begin{document}@."; List.iter (fun (i,_) -> fprintf fmt "@\n %i\\quad" i; fprintf fmt "\\includegraphics[width=\\textwidth,height=\\textwidth,keepaspectratio]{testbox.%d}" i; fprintf fmt "@\n \\vspace{3cm}@\n" ) figs; fprintf fmt "@]@\n\\end{document}@.") mlpost-0.8.1/signature.ml0000644000443600002640000000245111365367177014556 0ustar kanigdemons(**************************************************************************) (* *) (* 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 = Types.point type num = Types.num module type Boxlike = sig type t val width : t -> num val height : t -> num val set_pos : point -> t -> t end mlpost-0.8.1/brush.ml0000644000443600002640000000543411365367177013704 0ustar kanigdemons(**************************************************************************) (* *) (* 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.1/hash.ml0000644000443600002640000001245411365367177013504 0ustar kanigdemons(**************************************************************************) (* *) (* 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 color = | RGB of float * float * float | CMYK of float * float * float * float | Gray of float type name = string type corner = N | S | W | E | NE | NW | SW | SE type piccorner = UL | UR | LL | LR *) open Hashtbl open Types let combine n acc = acc * 65599 + n let combine2 n acc1 acc2 = combine n (combine acc1 acc2) let combine3 n acc1 acc2 acc3 = combine n (combine acc1 (combine acc2 acc3)) let combine4 n acc1 acc2 acc3 acc4 = combine n (combine3 acc1 acc2 acc3 acc4) type position = | Pcenter | Pleft | Pright | Ptop | Pbot | Pupleft | Pupright | Plowleft | Plowright let rec num = function | F f -> combine 1 (hash f) | NXPart p -> combine 2 (point p) | NYPart p -> combine 3 (point p) | NAdd(n,m) -> combine2 4 (num n) (num m) | NMinus(n,m) -> combine2 5 (num n) (num m) | NMult(n,m) -> combine2 6 (num n) (num m) | NDiv(n,m) -> combine2 7 (num n) (num m) | NMax(n,m) -> combine2 8 (num n) (num m) | NMin(n,m) -> combine2 9 (num n) (num m) | NGMean(n,m) -> combine2 10 (num n) (num m) | NLength p -> combine 11 (path p) and point = function | PTPair(n,m) -> combine2 12 (num n) (num m) | PTPicCorner(p,pc) -> combine2 13 (picture p) (hash pc) | PTPointOf(f,p) -> combine2 14 (hash f) (path p) | PTDirectionOf(f,p) -> combine2 15 (hash f) (path p) | PTAdd(p,q) -> combine2 16 (point p) (point q) | PTSub(p,q) -> combine2 17 (point p) (point q) | PTMult(n,q) -> combine2 18 (num n) (point q) | PTRotated(f,p) -> combine2 19 (hash f) (point p) | PTTransformed(p,l) -> List.fold_left (fun acc t -> combine2 21 acc (transform t)) (combine 20 (point p)) l (* and on_off = On of num | Off of num *) and direction = function | Vec p -> combine 61 (point p) | Curl f -> combine 62 (hash f) | NoDir -> 63 and joint = hash (* | JLine | JCurve | JCurveNoInflex | JTension of float * float | JControls of point * point *) and knot(d1,p,d2) = combine3 64 (direction d1) (point p) (direction d2) and path = function | PAConcat(k,j,p) -> combine3 22 (knot k) (joint j) (path p) | PACycle(d,j,p) -> combine3 23 (direction d) (joint j) (path p) | PAFullCircle -> 24 | PAHalfCircle -> 25 | PAQuarterCircle -> 26 | PAUnitSquare -> 27 | PATransformed(p,l) -> List.fold_left (fun acc t -> combine2 28 acc (transform t)) (combine 29 (path p)) l | PAKnot k -> combine 30 (knot k) | PAAppend(p1,j,p2) -> combine3 31 (path p1) (joint j) (path p2) | PACutAfter(p,q) -> combine2 32 (path p) (path q) | PACutBefore(p,q) -> combine2 33 (path p) (path q) | PABuildCycle l -> List.fold_left (fun acc t -> combine2 35 acc (path t)) 34 l | PASub(f1,f2,p) -> combine3 36 (hash f1) (hash f2) (path p) | PABBox p -> combine 37 (picture p) and transform = function | TRRotated f -> combine 52 (hash f) | TRScaled n -> combine 53 (num n) | TRShifted p -> combine 57 (point p) | TRSlanted n -> combine 54 (num n) | TRXscaled n -> combine 55 (num n) | TRYscaled n -> combine 56 (num n) | TRZscaled p -> combine 58 (point p) | TRReflect(p,q) -> combine2 59 (point p) (point q) | TRRotateAround(p,q) -> combine2 60 (point p) (hash q) and picture = function | PITex s -> combine 38 (hash s) | PIMake c -> combine 39 (command c) | PITransform(l,p) -> List.fold_left (fun acc t -> combine2 40 acc (transform t)) (combine 41 (picture p)) l | PIClip(p,q) -> combine2 42 (picture p) (path q) and dash = hash (* | DEvenly | DWithdots | DScaled of float * dash | DShifted of point * dash | DPattern of on_off list *) and pen = hash (* | PenCircle | PenSquare | PenFromPath of path | PenTransformed of pen * transform list *) and command = function | CDraw(pa,c,p,d) -> combine4 43 (path pa) (hash c) (hash p) (hash d) | CDrawArrow(pa,c,p,d) -> combine4 44 (path pa) (hash c) (hash p) (hash d) | CDrawPic p -> combine 45 (picture p) | CFill(p,c) -> combine2 46 (path p) (hash c) | CLabel(pic,pos,poi) -> combine3 47 (picture pic) (hash pos) (point poi) | CDotLabel(pic,pos,poi) -> combine3 48 (picture pic) (hash pos) (point poi) | CLoop(n,m,_) -> combine2 49 n m | CSeq l -> List.fold_left (fun acc t -> combine2 50 acc (command t)) 51 l mlpost-0.8.1/command.ml0000644000443600002640000000506311365367177014175 0ustar kanigdemons(**************************************************************************) (* *) (* 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 [] let set_verbosity = Types.set_verbosity mlpost-0.8.1/mlpost_no.mlpack0000644000443600002640000000042411365367177015424 0ustar kanigdemonsSignature Num Point MetaPath Path Pen Dash Color Brush Box Transform Picture Arrow Command Helpers Tree Tree_adv Diag Plot Real_plot Shapes Misc Metapost MPprint Generate Radar Hist Legend Cairost Concrete Print Types Compile Compiled_types Duplicate Hashcons Metapost_tool mlpost-0.8.1/INSTALL0000644000443600002640000000356711365367177013265 0ustar kanigdemonsDependencies: * 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. * To use Mlpost, you need metapost and metafun (packages texlive-metapost and context in debian) * 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.1/configure.in0000644000443600002640000003122611365367177014536 0ustar kanigdemons########################################################################## # # # 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.1,[],[],[]) # 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 3.10.0*) AC_MSG_ERROR(ocamlbuild is too buggy in this version. 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_CHECKING(ocamlbuild version) TMPVER=`$OCAMLBUILD -version | sed -n -e 's|.*ocamlbuild *\(.*\)$|\1|p' ` case $OCAMLVERSION in 3.10.1|3.10.2*) if test "$TMPVER" != "0.1"; then AC_MSG_ERROR(ocamlbuild version differs from ocamlc. Aborting.) else AC_MSG_RESULT(ok) fi ;; *) if test "$TMPVER" != "$OCAMLVERSION" ; then AC_MSG_ERROR(ocamlbuild version differs from ocamlc. Aborting.) else AC_MSG_RESULT(ok) fi ;; esac fi # Then check that we are dealing with ocamlbuild at the right place AC_MSG_CHECKING(ocamlbuild place) OCAMLBUILDLIB=$(ocamlbuild -where) if test "$OCAMLBUILDLIB" != "${OCAMLLIB}/ocamlbuild"; then echo "ocamlbuild present but your ocamlbuild is not compatible with your ocamlc:" echo "ocamlbuild : $OCAMLBUILDLIB, ocamlc : $OCAMLLIB" AC_MSG_ERROR(ocamlbuild not at the right place) 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" = yes; then OCAMLFINDLIB=$(ocamlfind printconf stdlib) OCAMLFIND=$(which ocamlfind) if test "$OCAMLFINDLIB" != "$OCAMLLIB"; then USEOCAMLFIND=no; echo "but your ocamlfind is not compatible with your ocamlc:" echo "ocamlfind : $OCAMLFINDLIB, ocamlc : $OCAMLLIB" fi fi if test "$LIBDIR" = ""; then if test "$USEOCAMLFIND" = yes; then LIBDIR=$(ocamlfind printconf destdir)/mlpost else LIBDIR=$OCAMLLIB/mlpost fi 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 if test "$USEOCAMLFIND" = yes; then CAIROLIB=$(ocamlfind query cairo) fi if test -n "$CAIROLIB";then echo "ocamlfind found cairo in $CAIROLIB" CAIRO=yes else AC_CHECK_FILE($OCAMLLIB/cairo/cairo.cma,CAIRO=yes,CAIRO=no) if test "$CAIRO" = yes; then CAIROLIB=$OCAMLLIB/cairo/ elif test -n "$OCAMLLIBLOCAL"; then AC_CHECK_FILE($OCAMLLIBLOCAL/cairo/cairo.cma,CAIRO=yes,CAIRO=no) if test "$CAIRO" = yes; then CAIROLIB=$OCAMLLIBLOCAL/cairo/ fi fi 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 if test "$USEOCAMLFIND" = yes; then BITSTRINGLIB=$(ocamlfind query bitstring) fi if test -n "$BITSTRINGLIB";then echo "ocamlfind found bitstring in $BITSTRINGLIB" BITSTRING=yes else AC_CHECK_FILE($OCAMLLIB/bitstring/bitstring.cma,BITSTRING=yes,BITSTRING=no) if test "$BITSTRING" = yes; then BITSTRINGLIB=$OCAMLLIB/bitstring/ elif test -n "$OCAMLLIBLOCAL"; then AC_CHECK_FILE($OCAMLLIBLOCAL/bitstring/bitstring.cma,BITSTRING=yes,BITSTRING=no) if test "$BITSTRING" = yes; then BITSTRINGLIB=$OCAMLLIBLOCAL/bitstring/ fi fi 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 if test "$USEOCAMLFIND" == yes; then LABLGTK2LIB=$(ocamlfind query lablgtk2) fi if test -n "$LABLGTK2LIB";then echo "ocamlfind found lablgtk2 in $LABLGTK2LIB" else AC_CHECK_FILE($OCAMLLIB/lablgtk2/lablgtk.cma,LABLGTK2=yes,LABLGTK2=no) if test "$LABLGTK2" = yes; then LABLGTK2LIB=$OCAMLLIB/lablgtk2/ elif test -n "$OCAMLLIBLOCAL"; then AC_CHECK_FILE($OCAMLLIBLOCAL/lablgtk2/lablgtk2.cma,LABLGTK2=yes,LABLGTK2=no) if test "$LABLGTK2" = yes; then LABLGTK2LIB=$OCAMLLIBLOCAL/lablgtk2/ fi fi fi fi ##AC_CHECK_FILE($OCAMLLIB/lablgtk2/lablgtk.cma,LABLGTK2=yes,LABLGTK2=no) ## AC_CHECK_PROG(LABLGTK2,lablgtk2,yes,no) not always available (Win32) if test -n "$LABLGTK2LIB" ; then LABLGTK2=yes dnl INCLUDEGTK2="-I $LABLGTK2LIB" INCLUDEGTK2="-I +lablgtk2" else LABLGTK2=no fi # checking for cairo.lablgtk2 if test "$USEOCAMLFIND" == yes; then CAIROLABLGTK2LIB=$(ocamlfind query cairo.lablgtk2) fi if test -n "$CAIROLABLGTK2LIB";then echo "ocamlfind found cairo.lablgtk2 in $CAIROLABLGTK2LIB" else AC_CHECK_FILE($OCAMLLIB/cairo/cairo_lablgtk.cma, CAIROLABLGTK2=yes,CAIROLABLGTK2=no) if test "$CAIROLABLGTK2" = yes; then CAIROLABLGTK2LIB=$OCAMLLIB/lablgtk2/ elif test -n "$OCAMLLIBLOCAL"; then AC_CHECK_FILE($OCAMLLIBLOCAL/cairo/cairo_lablgtk.cma, CAIROLABLGTK2=yes,CAIROLABLGTK2=no) if test "$CAIROLABLGTK2" = yes; then CAIROLABLGTK2LIB=$OCAMLLIBLOCAL/cairo/ fi fi 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(USEOCAMLFIND) 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.1/types.mli0000644000443600002640000002173111365367177014074 0ustar kanigdemons(**************************************************************************) (* *) (* 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 add_set_verbosity : (bool -> unit) -> unit val set_verbosity : bool -> unit type color = Concrete_types.color type name = string type corner = [ | `Northwest | `Northeast | `Southwest | `Southeast | `Upleft | `Upright | `Lowleft | `Lowright | `Upperleft | `Upperright | `Lowerleft | `Lowerright | `Topleft | `Topright | `Bottomleft | `Bottomright ] type corner_red = [ | `Northwest | `Northeast | `Southwest | `Southeast ] type hposition = [ `Center | `West | `East | `Left | `Right ] type vposition = [ `Center | `North | `South | `Top | `Bot (** deprecated *) | `Bottom ] type hposition_red = [ `Center | `West | `East ] type vposition_red = [ `Center | `North | `South ] type position = [ | hposition | vposition | corner ] type position_red = [ | hposition_red | vposition_red | corner_red ] open Hashcons type num_node = private | F of float | NXPart of point | NYPart of point | NAdd of num * num | NSub of num * num | NMult of num * num | NDiv of num * num | NMax of num * num | NMin of num * num | NGMean of num * num | NLength of path | NIfnullthenelse of num * num * num and num = num_node hash_consed and point_node = private | PTPair of num * num | PTPicCorner of commandpic * corner | PTPointOf of num * path | PTDirectionOf of num * path | PTAdd of point * point | PTSub of point * point | PTMult of num * point | PTRotated of float * point | PTTransformed of point * transform and point = point_node hash_consed and on_off_node = private | On of num | Off of num and on_off = on_off_node hash_consed and direction_node = private | Vec of point | Curl of float | NoDir and direction = direction_node hash_consed and joint_node = private | JLine | JCurve | JCurveNoInflex | JTension of float * float | JControls of point * point and joint = joint_node hash_consed and knot_node = private { knot_in : direction ; knot_p : point ; knot_out : direction } and knot = knot_node hash_consed and metapath_node = private | MPAConcat of knot * joint * metapath | MPAKnot of knot | MPAAppend of metapath * joint * metapath | MPAofPA of path (*| MPATransformed of metapath * transform*) and metapath = metapath_node hash_consed and path_node = private | PAofMPA of metapath | MPACycle of direction * joint * metapath | PAFullCircle | PAHalfCircle | PAQuarterCircle | PAUnitSquare | PATransformed of path * transform | PACutAfter of path * path | PACutBefore of path * path | PABuildCycle of path list | PASub of num * num * path | PABBox of commandpic and path = path_node hash_consed and matrix = { xx : num; yx : num; xy : num; yy : num; x0 : num; y0 : num; } and transform_node = private | TRRotated of float | TRScaled of num | TRShifted of point | TRSlanted of num | TRXscaled of num | TRYscaled of num | TRZscaled of point | TRReflect of point * point | TRRotateAround of point * float | TRMatrix of matrix and transform = transform_node hash_consed and dash_node = private | DEvenly | DWithdots | DScaled of num * dash | DShifted of point * dash | DPattern of on_off list and dash = dash_node hash_consed and pen_node = private | PenCircle | PenSquare | PenFromPath of path | PenTransformed of pen * transform and pen = pen_node hash_consed and picture_node = private | PITex of string | PITransformed of commandpic * transform | PIClip of commandpic * path and picture = picture_node hash_consed and command_node = private | CDraw of path * brush | CFill of path * color option | CLabel of commandpic * position * point | CDotLabel of commandpic * position * point | CExternalImage of string * spec_image and commandpic_node = private | Picture of picture | Command of command | Seq of commandpic list and commandpic = commandpic_node hash_consed 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 command = command_node hash_consed and brush_node = {pen : pen option; dash : dash option; color : color option} and brush = brush_node hash_consed (* smart constructors *) (* num *) val mkF: float -> num val mkNAdd : num -> num -> num val mkNSub : num -> num -> num val mkNMult : num -> num -> num val mkNDiv : num -> num -> num val mkNMax : num -> num -> num val mkNMin : num -> num -> num val mkNGMean : num -> num -> num val mkNXPart : point -> num val mkNYPart : point -> num val mkNLength : path -> num val mkNIfnullthenelse : num -> num -> num -> num (* point *) val mkPTPair : num -> num -> point val mkPTAdd : point -> point -> point val mkPTSub : point -> point -> point val mkPTMult : num -> point -> point val mkPTRotated : float -> point -> point val mkPTTransformed : point -> transform -> point val mkPTPointOf : num -> path -> point val mkPTDirectionOf : num -> path -> point val mkPTPicCorner : commandpic -> corner -> point (* transform *) val mkTRScaled : num -> transform val mkTRXscaled : num -> transform val mkTRYscaled : num -> transform val mkTRZscaled : point -> transform val mkTRRotated : float -> transform val mkTRShifted : point -> transform val mkTRSlanted : num -> transform val mkTRReflect : point -> point -> transform val mkTRRotateAround : point -> float -> transform val mkTRMatrix : matrix -> transform (* knot *) val mkKnot : direction -> point -> direction -> knot (* metapath *) val mkMPAKnot : knot -> metapath val mkMPAConcat : knot -> joint -> metapath -> metapath val mkMPAAppend : metapath -> joint -> metapath -> metapath val mkMPAofPA : path -> metapath (*val mkMPATransformed : path -> transform -> path*) (* path *) val mkPAofMPA : metapath -> path val mkPAKnot : knot -> path val mkPAConcat : knot -> joint -> path -> path val mkPACycle : direction -> joint -> path -> path val mkMPACycle : direction -> joint -> metapath -> path val mkPAAppend : path -> joint -> path -> path val mkPAFullCircle : path val mkPAHalfCircle : path val mkPAQuarterCircle : path val mkPAUnitSquare : path val mkPATransformed : path -> transform -> path val mkPACutAfter : path -> path -> path val mkPACutBefore : path -> path -> path val mkPABuildCycle : path list -> path val mkPASub : num -> num -> path -> path val mkPABBox : commandpic -> path (* joint *) val mkJCurve : joint val mkJLine : joint val mkJCurveNoInflex : joint val mkJTension: float -> float -> joint val mkJControls: point -> point -> joint (* direction *) val mkNoDir : direction val mkVec : point -> direction val mkCurl : float -> direction (* picture *) val mkPITex : string -> picture val mkPITransformed : commandpic -> transform -> picture val mkPIClip : commandpic -> path -> picture (* command *) val mkCDraw: path -> brush -> command val mkCFill: path -> color option -> command val mkCLabel: commandpic -> position -> point -> command val mkCDotLabel: commandpic -> position -> point -> command val mkCExternalImage : string -> spec_image -> command (* commandpic *) val mkPicture : picture -> commandpic val mkCommand : command -> commandpic val mkSeq : commandpic list -> commandpic (* dash *) val mkDEvenly: dash val mkDWithdots: dash val mkDScaled: num -> dash -> dash val mkDShifted: point -> dash -> dash val mkDPattern: on_off list -> dash (* pen *) val mkPenCircle: pen val mkPenSquare: pen val mkPenFromPath: path -> pen val mkPenTransformed: pen -> transform -> pen (* brush *) val mkBrush: color option -> pen option -> dash option -> brush val mkBrushOpt : brush option -> color option -> pen option -> dash option -> brush (* on_off *) val mkOn : num -> on_off val mkOff : num -> on_off val pos_reduce : position -> position_red val corner_reduce : corner -> corner_red val vreduce : vposition -> vposition_red val hreduce : hposition -> hposition_red val opposite_position : position -> position_red mlpost-0.8.1/ocamlbuild.Makefile0000644000443600002640000001262011365367177015774 0ustar kanigdemons########################################################################## # # # 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. # # # ########################################################################## TESTS = handbookgraphs.cmx othergraphs.cmx tests.cmx ifeq "$(OCAMLBEST)" "opt" TOOL= tool.native else TOOL= tool.byte OBOPTS += -byte-plugin endif ifeq "$(TERM)" "dumb" OCAMLBUILD_DISPLAY= -classic-display else OCAMLBUILD_DISPLAY= endif DTYPES = -tag dtypes OCAMLBUILD := $(OCAMLBUILDBIN) $(OBOPTS) -no-links $(DTYPES) $(TAGS) $(OCAMLBUILD_DISPLAY) -classic-display -log "build.log" BUILD := _build/ CMA := mlpost.cma mlpost_desc_options.cma mlpost_options.cma CMXA := mlpost.cmxa mlpost_desc_options.cmxa mlpost_options.cmxa OBJ := mlpost_desc_options$(LIBEXT) mlpost_options$(LIBEXT) ifeq "$(OCAMLBEST)" "opt" all: $(OCAMLBUILD) $(CMA) $(CMXA) $(TOOL) lib: $(OCAMLBUILD) $(CMA) $(CMXA) LIB_EXT=.cma .cmxa .cmi else all: $(OCAMLBUILD) $(CMA) $(TOOL) lib: $(OCAMLBUILD) $(CMA) LIB_EXT=.cma .cmi endif byte : $(OCAMLBUILD) $(CMA) tool.byte opt : $(OCAMLBUILD) $(CMXA) tool.native check: all $(TESTS) check-examples tool.byte: $(OCAMLBUILD) tool.byte tool.opt: $(OCAMLBUILD) tool.native tests: tests.ml $(OCAMLBUILD) tests.native $(BUILD)/tests.native make -C test tests $(PSVIEWER) test/tests.ps testbox: testbox.ml $(OCAMLBUILD) testbox.native $(BUILD)/testbox.native make -C test testbox $(PSVIEWER) test/testbox.ps tests.pdf: tests.ml $(OCAMLBUILD) tests.native $(BUILD)/tests.native make -C test tests.pdf $(PDFVIEWER) test/tests.pdf tests.byte: tests.ml $(OCAMLBUILD) tests.byte $(BUILD)/tests.byte make -C test tests $(PSVIEWER) test/tests.ps handbook.pdf : handbookgraphs.ml $(OCAMLBUILD) handbookgraphs.native $(BUILD)/handbookgraphs.native make -C test manual make -C test/manual mpost handbook: handbook.pdf $(PDFVIEWER) test/testmanual.pdf handbook.byte: handbookgraphs.ml $(OCAMLBUILD) handbookgraphs.byte $(BUILD)/handbookgraphs.byte make -C test manual make -C test/manual mpost $(PSVIEWER) test/testmanual.ps other.pdf: othergraphs.ml $(OCAMLBUILD) othergraphs.native $(BUILD)/othergraphs.native make -C test other make -C test/othergraphs mpost other: other.pdf $(PDFVIEWER) test/othergraphs.pdf other.byte: othergraphs.ml $(OCAMLBUILD) othergraphs.byte $(BUILD)/othergraphs.byte make -C test other make -C test/othergraphs mpost $(PSVIEWER) test/othergraphs.ps .PHONY: check-examples examples SUBDIRMLPOST:=../$(BUILD)tool.native -libdir ../$(BUILD) -v -ps -native MAKEEXAMPLES=$(MAKE) -C examples MLPOST='$(SUBDIRMLPOST)' check-examples: mlpost.cma tool.opt $(MAKEEXAMPLES) boxes.dummy $(MAKEEXAMPLES) paths.dummy $(MAKEEXAMPLES) tree.dummy $(MAKEEXAMPLES) label.dummy make -C multi-examples examples: tool.opt $(MAKEEXAMPLES) examples-contrib: tool.opt $(MAKEEXAMPLES) contrib examples-html: tool.opt $(MAKEEXAMPLES) html # Contrib contrib: dot-contrib lablgtk-contrib dot-contrib : lib @echo "make: Entering directory \`$(shell pwd)/contrib/dot'" cd contrib/dot && $(OCAMLBUILDBIN) -tag dtypes -cflags -I,$(shell pwd)/_build $(addprefix mlpost_dot,$(LIB_EXT)) && cd ../.. ln -sf contrib/dot/_build _build_dot ifeq "$(LABLGTK2)$(CAIROLABLGTK2)$(USEOCAMLFIND)" "yesyesyes" lablgtk-contrib : lib @echo "make: Entering directory \`$(shell pwd)/contrib/lablgtk'" cd contrib/lablgtk && $(OCAMLBUILDBIN) -tag dtypes -cflags -I,$(shell pwd)/_build \ -cflags -I,$(LABLGTK2LIB) \ -cflags -I,$(CAIROLABLGTK2LIB) \ $(addprefix mlpost_lablgtk,$(LIB_EXT)) && cd ../.. ln -sf contrib/lablgtk/_build _build_lablgtk else lablgtk-contrib : @echo "lablgtk2 or cairo.lablgtk2 hasn't been found I can't make mlpost_lablgtk" endif clean-contrib: cd contrib/dot && $(OCAMLBUILDBIN) -clean && cd ../.. cd contrib/lablgtk && $(OCAMLBUILDBIN) -clean && cd ../.. # GUI .PHONY: gui gui/gmlpost.native gui/glexer.cmo gui/glexer.cmi gui: gui/gmlpost.native gui/glexer.cmo gui/gmlpost.native: $(OCAMLBUILD) gui/gmlpost.native gui/gmlpost.byte: $(OCAMLBUILD) gui/gmlpost.byte gui/glexer.cmo: $(OCAMLBUILD) gui/glexer.cmo # building the doc ################## .PHONY: doc doc: rm -f doc $(OCAMLBUILD) doc/index.html ln -s _build/doc doc # clean ####### clean:: rm -rf doc rm -f test.dvi test.ps *.exe $(OCAMLBUILD) -clean cleaner:: clean make -C test clean make -C multi-examples clean make -C www clean make -C examples clean dist-clean distclean:: clean rm -f Makefile config.cache config.log config.status META version.ml myocamlbuild.ml ocamlbuild.Makefile simple.Makefile mlpost-0.8.1/concrete.ml0000644000443600002640000001501711365367177014361 0ustar kanigdemons(**************************************************************************) (* *) (* 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 let set_verbosity b = Compute.set_verbosity b let set_prelude filename = Compute.set_prelude (Metapost_tool.read_prelude_from_tex_file filename) let set_t1disasm opt = Fonts.t1disasm := opt let set_prelude2 prelude = match prelude with | None -> Compute.set_prelude "" | Some p -> Compute.set_prelude p type cnum = float module CPoint = Point_lib module CPath = struct module S = Spline_lib type t = S.path type abscissa = float let length = S.metapost_length let is_closed = S.is_closed let is_a_point x = S.is_a_point x let c_metapost_of_abscissa p1 p2 (t1,t2) = S.metapost_of_abscissa p1 t1, S.metapost_of_abscissa p2 t2 let intersection p1 p2 = List.map (c_metapost_of_abscissa p1 p2) (S.intersection p1 p2) let one_intersection p1 p2 = c_metapost_of_abscissa 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 p t = S.split p (S.abscissa_of_metapost p t) let subpath p t1 t2 = S.subpath p (S.abscissa_of_metapost p t1) (S.abscissa_of_metapost p t2) let direction_of_abscissa p t1 = S.direction_of_abscissa p (S.abscissa_of_metapost p t1) let point_of_abscissa p t1 = S.abscissa_to_point p (S.abscissa_of_metapost p t1) let bounding_box = S.bounding_box let dist_min_point path point = let d, a = S.dist_min_point path point in d, S.metapost_of_abscissa path (a) let dist_min_path path1 path2 = let d, (a1, a2) = S.dist_min_path path1 path2 in d, c_metapost_of_abscissa path1 path2 (a1,a2) let print = S.print end module CTransform = Matrix let float_of_num = LookForTeX.num let compute_nums = LookForTeX.compute_nums let cpoint_of_point = LookForTeX.point let cpath_of_path = LookForTeX.path let ctransform_of_transform = LookForTeX.transform let baselines s = Picture_lib.baseline (LookForTeX.picture (Types.mkPITex s)) let num_of_float f = Types.mkF f let point_of_cpoint p = let x = Types.mkF p.CPoint.x in let y = Types.mkF p.CPoint.y in Types.mkPTPair x y 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 p = [Types.mkTRMatrix {Types.x0 = Types.mkF p.Ctypes.x0; Types.y0 = Types.mkF p.Ctypes.y0; Types.xx = Types.mkF p.Ctypes.xx; Types.xy = Types.mkF p.Ctypes.xy; Types.yx = Types.mkF p.Ctypes.yx; Types.yy = Types.mkF p.Ctypes.yy}] ELSE let supported = false let not_supported s = failwith ("Concrete."^s^" : not supported") (* these are only configuration; we silently do nothing here *) let set_verbosity _ = () let set_prelude _ = () let set_t1disasm _ = () let set_prelude2 _ = () 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.1/duplicate.ml0000644000443600002640000001347311365367177014535 0ustar kanigdemons(**************************************************************************) (* *) (* 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 Num = struct type t = num_node hash_consed let equal = (==) let hash x = x.hkey end module Point = struct type t = point_node hash_consed let equal = (==) let hash x = x.hkey end 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 NM = Hashtbl.Make (Num) module PtM = Hashtbl.Make (Point) module MPthM = Hashtbl.Make (MetaPath) module PthM = Hashtbl.Make (Path) module PicM = Hashtbl.Make (Picture) let num_map = NM.create 257 let point_map = PtM.create 257 let path_map = PthM.create 257 let picture_map = PicM.create 257 let test_and_incr_num n = try incr (NM.find num_map n) ; true with Not_found -> NM.add num_map n (ref 1) ; false let test_and_incr_point n = try incr (PtM.find point_map n); true with Not_found -> PtM.add point_map n (ref 1); false 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 num' = function | F _ -> () | NXPart p | NYPart p -> point p | NAdd(n1,n2) | NSub(n1,n2) | NMult (n1,n2) | NDiv (n1,n2) | NMax (n1,n2) | NMin (n1,n2) | NGMean (n1,n2) -> num n1; num n2 | NLength p -> path p | NIfnullthenelse (n,n1,n2) -> num n; num n1; num n2 and num n = if test_and_incr_num n then () else num' n.node and point' = function | PTPair (f1,f2) -> num f1; num f2 | PTPointOf (f,p) | PTDirectionOf (f,p) -> path p ; num f | PTAdd (p1,p2) | PTSub (p1,p2) -> point p1; point p2 | PTMult (f,p) -> num f; point p | PTRotated (f,p) -> point p | PTPicCorner (pic, corner) -> commandpic pic | PTTransformed (p,tr) -> point p ; transform tr and point p = if test_and_incr_point p then () else point' p.node and direction d = match d.node with | Vec p -> point p | Curl _ | NoDir -> () and joint j = match j.node with | JLine | JCurve | JCurveNoInflex | JTension _ -> () | JControls (p1,p2) -> point p1; point p2 and knot k = match k.Hashcons.node with | { knot_in = d1 ; knot_p = p ; knot_out = d2 } -> direction d1; point p; direction d2 and metapath p = match p.Hashcons.node with | MPAConcat (k,j,p) -> knot k; joint j; metapath p | MPAAppend (p1,j,p2) -> metapath p1; joint j; metapath p2 | MPAKnot k -> knot k | MPAofPA p -> path p and path' = function | PAofMPA p -> metapath p | MPACycle (d,j,p) -> direction d; joint j; metapath p | PATransformed (p,tr) -> path p; transform tr | PACutAfter (p1,p2) | PACutBefore (p1,p2) -> path p1; path p2 | PABuildCycle pl -> List.iter path pl | PASub (f1, f2, p) -> num f1; num f2; 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,tr) -> transform tr; 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 transform t = match t.node with | TRRotated f -> () | TRScaled f | TRSlanted f | TRXscaled f | TRYscaled f -> num f | TRShifted p | TRZscaled p -> point p | TRReflect (p1,p2) -> point p1; point p2 | TRRotateAround (p,f) -> point p | TRMatrix p -> num p.x0; num p.y0; num p.xx; num p.xy; num p.yx; num p.yy and command c = match c.node with | CDraw (p, b) -> path p; brush b | CFill (p, c) -> path p | CDotLabel (pic, pos, pt) -> commandpic pic; point pt | CLabel (pic, pos ,pt) -> commandpic pic; point pt | 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, tr) -> pen p; transform tr and dash d = match d.Hashcons.node with | DEvenly | DWithdots -> () | DScaled (f, d) -> dash d | DShifted (p,d) -> point p; dash d | DPattern l -> List.iter dash_pattern l and dash_pattern o = match o.Hashcons.node with | On f | Off f -> num f and commandpic p = match p.node with | Picture p -> picture p | Command c -> command c | Seq l -> List.iter commandpic l mlpost-0.8.1/mlpost_yeslablgtk.odocl0000644000443600002640000000004011365367177016774 0ustar kanigdemonsMlpost Mlpost_dot Mlpost_lablgtkmlpost-0.8.1/Makefile.in0000644000443600002640000002310211365367177014264 0ustar kanigdemons########################################################################## # # # 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@ USEOCAMLFIND=@USEOCAMLFIND@ 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)) BCMXA = $(addprefix $(BUILD), $(CMXA) $(OBJ)) 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) install-opt: $(OCAMLFIND) remove $(DESTDIR) mlpost $(OCAMLFIND) install $(DESTDIR) mlpost $(BUILD)mlpost$(LIBEXT) $(BUILD)mlpost.cmi META $(BCMXA) $(BCMA) install-byte-dot: $(OCAMLFIND) remove $(DESTDIR) mlpost_dot $(OCAMLFIND) install $(DESTDIR) mlpost_dot contrib/dot/META \ $(addprefix contrib/dot/_build/mlpost_dot,.cmi .cma) 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)) ifeq "$(LABLGTK2)$(CAIROLABLGTK2)$(USEOCAMLFIND)" "yesyesyes" install-byte-lablgtk: $(OCAMLFIND) remove $(DESTDIR) mlpost_lablgtk $(OCAMLFIND) install $(DESTDIR) mlpost_lablgtk contrib/lablgtk/META \ $(addprefix contrib/lablgtk/_build/mlpost_lablgtk,.cmi .cma) 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)) else install-byte-lablgtk: install-opt-lablgtk: endif endif install-byte-contrib: install-byte-dot install-byte-lablgtk install-bin: mkdir -p $(BINDIR) 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 ######## 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)" > 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.1/mlpost_cairo.mlpack0000644000443600002640000000077511365367177016116 0ustar kanigdemonsSignature Num Point MetaPath Path Pen Dash Color Brush Box Transform Picture Arrow Command Helpers Tree Tree_adv Diag Plot Real_plot Shapes Misc Metapost MPprint Generate Radar Hist Legend Cairost Metapost_tool Concrete Concrete_types Print Types Compile Compiled_types Duplicate Hashcons Icairost Picture_lib Spline Spline_lib Fonts T1disasm Tfm Dvi Dvicairo Dviinterp Matrix Point_lib Compute Pfb_lexer Pfb_parser Map_lexer Map_parser Dev_save Gentex LookForTeX Unionfind Metapath_lib Draw Ctypes Metric mlpost-0.8.1/picture.ml0000644000443600002640000000756211365367177014240 0ustar kanigdemons(**************************************************************************) (* *) (* 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 = commandpic let tex s = mkPicture (mkPITex s) let make l = l let empty = mkSeq [] let bbox pic = mkPABBox pic let ulcorner pic = mkPTPicCorner pic `Northwest let llcorner pic = mkPTPicCorner pic `Southwest let urcorner pic = mkPTPicCorner pic `Northeast let lrcorner pic = mkPTPicCorner pic `Southeast let north_west = ulcorner let south_west = llcorner let north_east = urcorner let south_east = lrcorner let corner_bbox ?(dx=Num.zero) ?(dy=Num.zero) pic = let pdx = Point.pt (dx, Num.zero) in let pdy = Point.pt (Num.zero, dy) in Path.pathp ~style:Path.jLine ~cycle:Path.jLine [Point.add (Point.sub (ulcorner pic) pdx) pdy; Point.sub (Point.sub (llcorner pic) pdx) pdy; Point.sub (Point.add (lrcorner pic) pdx) pdy; Point.add (Point.add (urcorner pic) pdx) pdy] let transform trl p = List.fold_left (fun acc tr -> mkPicture (mkPITransformed acc tr)) p trl let ctr pic = Point.segment 0.5 (llcorner pic) (urcorner pic) let scale f p = transform [Transform.scaled f] p let rotate f p = transform [Transform.rotated f] p let shift pt p = transform [Transform.shifted pt] p let yscale n p = transform [Transform.yscaled n] p let xscale n p = transform [Transform.xscaled n] p let spin f p = transform [Transform.rotate_around (ctr p) f] p let place f pic p = shift (Point.sub p (f pic)) pic let center p pic = place ctr pic p let place_up_left p pic = place ulcorner pic p let place_up_right p pic = place urcorner pic p let place_bot_left p pic = place llcorner pic p let place_bot_right p pic = place lrcorner pic p let beside p1 p2 = mkSeq [p1; place_up_left (urcorner p1) p2] let below p1 p2 = mkSeq [p1; place_up_left (llcorner p1) p2] let clip pic pth = mkPicture (mkPIClip pic pth) let width p = Point.xpart (Point.sub (urcorner p) (ulcorner p)) let height p = Point.ypart (Point.sub (urcorner p) (lrcorner p)) let north p = Point.segment 0.5 (north_east p) (north_west p) let south p = Point.segment 0.5 (south_east p) (south_west p) let west p = Point.segment 0.5 (south_west p) (north_west p) let east p = Point.segment 0.5 (north_east p) (south_east p) let corner pos x = match pos_reduce pos 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 type escaped = [`Backslash |`Underscore] let rec escaped_to_list acc = function | [] -> acc | `Underscore::l -> escaped_to_list (('_',"\\_")::acc) l | `Backslash::l -> escaped_to_list (('\\',"\\backslash")::acc) l let escape_latex l = Misc.generic_quote_list (escaped_to_list [] l) let escape_all = escape_latex [`Backslash;`Underscore] let set_pos = center mlpost-0.8.1/misc.ml0000644000443600002640000000722611365367177013515 0ustar kanigdemons(**************************************************************************) (* *) (* 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 write_to_file filename f = let chan = open_out filename in f chan; close_out chan let write_to_formatted_file filename f = write_to_file filename (fun chan -> let fmt = Format.formatter_of_out_channel chan in f fmt; Format.fprintf fmt "@?") let print_option start printer fmt = function | None -> () | Some o -> Format.fprintf fmt "%s%a " start printer o 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 space fmt () = Format.fprintf fmt "@ " let comma fmt () = Format.fprintf fmt ",@ " let semicolon fmt () = Format.fprintf fmt ";@ " let newline fmt () = Format.fprintf fmt "@\n " let rec fold_from_to f acc a b = if a <= b then fold_from_to f (f acc a) (a+1) b else acc let sprintf s = let buf = Buffer.create 1024 in let fmt = Format.formatter_of_buffer buf in Format.kfprintf (fun _ -> Format.pp_print_flush fmt (); Buffer.contents buf) fmt s (*Filename.generic_quote*) let generic_quote whatquote quotequote s = let l = String.length s in let b = Buffer.create (l + 20) in for i = 0 to l - 1 do if s.[i] = whatquote then Buffer.add_string b quotequote else Buffer.add_char b s.[i] done; Buffer.contents b let generic_quote_list lwqq s = let l = String.length s in let b = Buffer.create (l + 20) in for i = 0 to l - 1 do if List.mem_assoc s.[i] lwqq then Buffer.add_string b (List.assoc s.[i] lwqq) else Buffer.add_char b s.[i] done; Buffer.contents b let call_cmd ?(inv=false) ?(outv=false) ?(verbose=false) cmd = (* inv = true -> print command line * outv = true -> print command output * verbose = true -> both *) if inv || verbose then Format.printf "+ %s@." cmd; let inc = Unix.open_process_in cmd in let buf = Buffer.create 16 in (try while true do Buffer.add_channel buf inc 1 done with End_of_file -> ()); let status = Unix.close_process_in inc in let outp = Buffer.contents buf in if outv || verbose then Format.printf "%s@?" outp; (match status with | Unix.WEXITED n -> n | _ -> exit 1), outp (* persistent queues *) module Q = struct type 'a t = 'a list * 'a list exception Empty let empty = [], [] let push x (i, o) = (x :: i, o) let pop = function | [], [] -> raise Empty | (i, x :: o) -> x, (i, o) | (i, []) -> match List.rev i with | x :: o -> x, ([], o) | [] -> assert false let of_list l = List.fold_left (fun q c -> push c q) empty l end mlpost-0.8.1/concrete/0000755000443600002640000000000011365367167014022 5ustar kanigdemonsmlpost-0.8.1/concrete/spline_lib.mli0000644000443600002640000001140211365367177016644 0ustar kanigdemons(**************************************************************************) (* *) (* 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 -> float val metapost_length : path -> float (** It's not the real length of the path *) 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 val abscissa_of_metapost : path -> float -> abscissa val metapost_of_abscissa : path -> abscissa -> float mlpost-0.8.1/concrete/unionfind.ml0000644000443600002640000000604711365367177016355 0ustar kanigdemons(**************************************************************************) (* *) (* 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.1/concrete/unionfind.mli0000644000443600002640000000363711365367177016530 0ustar kanigdemons(**************************************************************************) (* *) (* 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.1/concrete/point_lib.mli0000644000443600002640000000370411365367177016511 0ustar kanigdemons(**************************************************************************) (* *) (* 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 mlpost-0.8.1/concrete/ctypes.mli0000644000443600002640000000052511365367177016037 0ustar kanigdemonsIFDEF 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.1/concrete/myocamlbuild.ml0000644000443600002640000001077111365367177017044 0ustar kanigdemons(**************************************************************************) (* *) (* 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.1/concrete/concrete_types.ml0000644000443600002640000000025611365367177017406 0ustar kanigdemonstype 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.1/concrete/matrix.mli0000644000443600002640000000105511365367177016033 0ustar kanigdemonstype 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 mlpost-0.8.1/concrete/spline.ml0000644000443600002640000002677111365367177015664 0ustar kanigdemonsopen 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; smin : abscissa; smax : abscissa; } 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 "@[%f|%f { %a,@ %a,@ %a,@ %a }@]@." pt.smin pt.smax pt_f pt.sa pt_f pt.sb pt_f pt.sc pt_f pt.sd let s_of_01 s t = t *. (s.smax -. s.smin) +. s.smin let _01_of_s s t = (t -. s.smin) /. (s.smax -. s.smin) let create ?(min=0.) ?(max=1.) a b c d = { sa = a; sb = b; sc = c; sd = d; smin = min; smax = max; } let create_with_offset offs a b c d = create ~min:offs ~max:(offs +. 1.) a b c d let min t = t.smin let max t = t.smax let explode s = s.sa, s.sb, s.sc, s.sd let set_min_max fmin fmax b = { b with smin = fmin b.smin ; smax = fmax b.smax } let reverse conv {sa=sa;sb=sb;sc=sc;sd=sd;smin=smin;smax=smax} = {sa=sd;sb=sc;sc=sb;sd=sa; smin=conv smax; smax=conv smin} 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 = point_of s (_01_of_s 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 float*float let one_intersection a b = let nmax = 2.**(float_of_int (!inter_depth+1)) in let f_from_i s x = s_of_01 s ((float_of_int x)*.(1./.nmax)) in try intersect_fold (fun (x,y) () -> raise (Found (f_from_i a x,f_from_i b y))) () a b ; raise Not_found with Found (t1,t2) -> t1,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 s x = s_of_01 s (x *. (1./.nmax)) in let res = List.rev_map (fun (x,y) -> (f_from_i a x,f_from_i b 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 = if t = s.smax then Max else if t = s.smin 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;smax = t0}, {s with sa = a2;sb = b2;sc = c2;smin = t}) 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, s_of_01 s 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,(s_of_01 s1 t1,s_of_01 s2 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), (min s1, min s2) in aux s1 s2 pmin 0 0 (int_of_float nmax) !inter_depth let translate t a = { a with sa= a.sa +/ t; sb=a.sb +/ t; sc=a.sc +/ t; sd=a.sd +/ t } let transform t a = { a with 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.1/concrete/spline_lib.ml0000644000443600002640000002772211365367177016507 0ustar kanigdemons(**************************************************************************) (* *) (* 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 f = invalid_arg (f^": the abscissa given is greater than max_abscissa") 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 -> Spline.min (List.hd p.pl) | Point _ -> 0. let max_abscissa = function | Path p -> let rec aux = function | [] -> assert false | [a] -> Spline.max a | a::l -> aux l in aux p.pl | Point _ -> 0. 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 (Spline.max e)) :: 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 smax -> Spline.create_with_offset smax 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 smax -> Spline.create_with_offset smax 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 smax -> Spline.create_with_offset smax a sb sc d) p []) let abscissa_to_point p0 t = match p0 with | Path p -> let rec aux = function |[] -> Error.max_absc "abscissa_to_point" | a::l when Spline.max a >= t -> Spline.point_of_s a t | _::l -> aux l in if min_abscissa p0 > t then Error.min_absc "abscissa_to_point" else aux p.pl | Point p when t = 0. -> p | Point _ -> Error.absc_point "abscissa_to_point" let metapost_of_abscissa p0 t = match p0 with | Path p -> let rec aux s = function |[] -> Error.max_absc "metapost_of_abscissa" | a::l when Spline.max a >= t -> s +.(Spline._01_of_s a t) | _::l -> aux (s+.1.) l in if min_abscissa p0 > t then Error.min_absc "metapost_of_abscissa" else aux 0. p.pl | Point p when t = 0. -> 0. | Point _ -> Error.absc_point "metapost_of_abscissa" let abscissa_of_metapost p0 t = match p0 with | Path p -> let rec aux t = function |[] -> Error.max_absc "abscissa_of_metapost" | a::l when 1. >= t -> Spline.s_of_01 a t | _::l -> aux (t-.1.) l in if 0. > t then Error.min_absc ~value:t "abscissa_of_metapost" else aux t p.pl | Point p when t = 0. -> 0. | Point _ -> Error.absc_point "abscissa_of_metapost" let direction_of_abscissa p0 t = match p0 with | Point _ -> Error.dir_point "direction_of_abscissa" | Path p -> let rec aux = function |[] -> Error.max_absc "direction_of_abscissa" | a::_ when Spline.max a >= t -> Spline.direction a (Spline._01_of_s a t) | _::l -> aux l in if min_abscissa p0 > t then Error.min_absc "direction_of_abscissa" else aux p.pl 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::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 l in begin match ap0 with | Path ap -> let spl = with_last (fun _ sa smin -> Spline.create_with_offset smin 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 ap0 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 rec aux = function |[] -> Error.max_absc "split" | a::l when Spline.max a > t -> split_aux a t l | a::l -> let (p1,p2) = aux l in (a::p1,p2) in if min_abscissa p0 > t then Error.min_absc "split" else let (p1,p2) = aux 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 = fst (split (snd (split p t1)) t2) let cut_before a b = 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 = 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]) let length p = max_abscissa p -. min_abscissa p let metapost_length = function | Point _ -> 0. | Path p -> float_of_int (List.length p.pl) mlpost-0.8.1/concrete/_tags0000644000443600002640000000011511365367177015040 0ustar kanigdemons : pkg_cairo : syntax_macro <*.cmx> : for-pack(Mlpost) mlpost-0.8.1/concrete/point_lib.ml0000644000443600002640000000617011365367177016340 0ustar kanigdemons(**************************************************************************) (* *) (* 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.1/concrete/spline.mli0000644000443600002640000000747011365367177016030 0ustar kanigdemonstype 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 : ?min:float -> ?max:float -> 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.]. @param min give minimal abscissa @param max give maximal abscissa *) val create_with_offset : float -> point -> point -> point -> point -> t (** create a spline with abscissa between [ [f,f+1] ] *) val min : t -> abscissa (** minimal abscissa *) val max : t -> abscissa (** maximal abscissa *) 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 set_min_max : (float -> float) -> (float -> float) -> t -> t (** set the minimal and maximal abscissa using two functions. *) 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 _01_of_s : t -> abscissa -> abscissa (** take an abscissa on spline [s], and compute its position as if minimal and maximal abscissa of the spline were 0. and 1. *) val s_of_01 : t -> abscissa -> abscissa (** inverse of _01_of_s: take an abscissa between 0. and 1. and return the corresponding abscissa of the spline, taking into account its minimal and maximal abscissa *) 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.1/concrete/metapath_lib.ml0000644000443600002640000005304011365367177017010 0ustar kanigdemons(**************************************************************************) (* *) (* 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 smin = function | {right = Endpoint} -> [] | {right = Explicit sb;coord = sa; link={left = Explicit sc;coord = sd} as s} -> Spline.create ~min:smin ~max:(smin +. 1.) sa sb sc sd :: (if s==knots then [] else (aux (smin+.1.) s)) | _ -> assert false in aux 0. 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.1/concrete/metapath_lib.mli0000644000443600002640000000512111365367177017156 0ustar kanigdemons(**************************************************************************) (* *) (* 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.1/concrete/matrix.ml0000644000443600002640000000566611365367177015676 0ustar kanigdemons(**************************************************************************) (* *) (* 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.1/name.ml0000644000443600002640000000335111365367177013475 0ustar kanigdemons(**************************************************************************) (* *) (* 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 = string let create prefix = let r = ref 0 in fun () -> incr r; prefix ^ string_of_int !r let node = create "node" let rec alpha i = if 0 <= i && i <= 22 then String.make 1 (Char.chr (Char.code 'a' + i)) else alpha (i / 22) ^ alpha (i mod 22) let path = let r = ref 0 in fun () -> incr r; "path" ^ alpha !r let picture = let r = ref 0 in fun () -> incr r; "pic" ^ alpha !r let point = let r = ref 0 in fun () -> incr r; "pot" ^ alpha !r let num = let r = ref 0 in fun () -> incr r; "num" ^ alpha !r let transform = let r = ref 0 in fun () -> incr r; "trans" ^ alpha !r mlpost-0.8.1/LICENSE0000644000443600002640000006561611365367177013244 0ustar kanigdemonsThe 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.1/transform.ml0000644000443600002640000000336611365367177014576 0ustar kanigdemons(**************************************************************************) (* *) (* 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' = transform type t = t' list let scaled a = mkTRScaled a let rotated a = mkTRRotated a let shifted a = mkTRShifted a let slanted a = mkTRSlanted a let xscaled a = mkTRXscaled a let yscaled a = mkTRYscaled a let zscaled a = mkTRZscaled a let reflect p1 p2 = mkTRReflect p1 p2 let rotate_around p f = mkTRRotateAround p f type matrix = Types.matrix = { xx : Num.t; yx : Num.t; xy : Num.t; yy : Num.t; x0 : Num.t; y0 : Num.t; } let explicit t = mkTRMatrix t (* applied the transformations in the order of the list *) let id = [] mlpost-0.8.1/mPprint.ml0000644000443600002640000002446611365367177014220 0ustar kanigdemons(**************************************************************************) (* *) (* 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 Misc open Concrete_types open Types module C = Compiled_types let externalimage_dimension filename : float * float = let inch = Unix.open_process_in ("identify -format \"%h\\n%w\" "^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 "Unknown external image" let name = pp_print_string let piccorner fmt p = match corner_reduce p with | `Northwest -> fprintf fmt "ulcorner" | `Northeast -> fprintf fmt "urcorner" | `Southwest -> fprintf fmt "llcorner" | `Southeast -> fprintf fmt "lrcorner" let position fmt p = match pos_reduce p with | `Center -> fprintf fmt "" | `West -> fprintf fmt ".lft" | `East -> fprintf fmt ".rt" | `North -> fprintf fmt ".top" | `South -> fprintf fmt ".bot" | `Northwest -> fprintf fmt ".ulft" | `Northeast -> fprintf fmt ".urt" | `Southwest -> fprintf fmt ".llft" | `Southeast -> fprintf fmt ".lrt" let rec num fmt = function | C.F f -> if f = infinity then fprintf fmt "infinity" else if f > 4095. then fprintf fmt "%g" 4095. else if abs_float f < 0.0001 then fprintf fmt "0" else fprintf fmt "%g" f | C.NXPart p -> fprintf fmt "xpart %a" point p | C.NYPart p -> fprintf fmt "ypart %a" point p | C.NAdd (f1, f2) -> fprintf fmt "(%a +@ %a@,)" num f1 num f2 | C.NSub (f1, f2) -> fprintf fmt "(%a -@ %a@,)" num f1 num f2 | C.NMult (f1, f2) -> fprintf fmt "(%a *@ %a@,)" num f1 num f2 | C.NDiv (f1, f2) -> fprintf fmt "(%a /@ %a@,)" num f1 num f2 | C.NMax (f1, f2) -> fprintf fmt "max(@ %a,@ %a@,)" num f1 num f2 | C.NMin (f1, f2) -> fprintf fmt "min(@ %a,@ %a@,)" num f1 num f2 | C.NGMean (f1, f2) -> fprintf fmt "(%a@ ++@ %a@,)" num f1 num f2 | C.NName n -> pp_print_string fmt n | C.NLength p -> fprintf fmt "length (%a@,)" path p | C.NIfnullthenelse (n,n1,n2) -> fprintf fmt "(if (%a = 0): %a else: %a fi)" num n num n1 num n2 and float fmt f = num fmt (C.F f) and scolor fmt = function | RGB (r,g,b) -> fprintf fmt "(%a, %a , %a@,)" float r float g float b | CMYK (c,m,y,k) -> fprintf fmt "(%a, %a, %a, %a@,)" float c float m float y float k | Gray f -> fprintf fmt "%a * white" float f and color fmt = function | OPAQUE c -> scolor fmt c | TRANSPARENT (f,c) -> fprintf fmt "transparent (1,%a,%a@,)" float f scolor c (* 1 is the "normal" mode *) and point fmt = function | C.PTPair (m,n) -> fprintf fmt "(%a,@ %a@,)" num m num n | C.PTPicCorner (pic, d) -> fprintf fmt "(%a@ %a@,)" piccorner d picture pic | C.PTAdd (p1, p2) -> fprintf fmt "(%a +@ %a@,)" point p1 point p2 | C.PTSub (p1, p2) -> fprintf fmt "(%a -@ %a@,)" point p1 point p2 | C.PTMult (f, p) -> fprintf fmt "(%a *@ %a@,)" num f point p | C.PTRotated (f, p) -> fprintf fmt "(%a rotated@ %a@,)" point p float f | C.PTPointOf (f, p) -> fprintf fmt "(point %a@ of (%a))" num f path p | C.PTDirectionOf (f, p) -> fprintf fmt "(direction %a@ of (%a))" num f path p | C.PTTransformed (p,tr) -> fprintf fmt "((%a)@ %a@,)" point p transform tr | C.PTName pn -> pp_print_string fmt pn and transform fmt = function | C.TRScaled a -> fprintf fmt "scaled %a@," num a | C.TRShifted a -> fprintf fmt "shifted %a@," point a | C.TRRotated a -> fprintf fmt "rotated %a@," float a | C.TRSlanted a -> fprintf fmt "slanted %a@," num a | C.TRXscaled a -> fprintf fmt "xscaled %a@," num a | C.TRYscaled a -> fprintf fmt "yscaled %a@," num a | C.TRZscaled a -> fprintf fmt "zscaled %a@," point a | C.TRReflect (p1,p2) -> fprintf fmt "reflectedabout (%a,@ %a)@," point p1 point p2 | C.TRRotateAround (p,f) -> fprintf fmt "rotatedaround(%a,@ %a)@," point p float f | C.TRName tn -> fprintf fmt "transformed %s" tn and picture fmt = function | C.PITex s -> fprintf fmt "btex %s etex" s | C.PITransformed (p, tr) -> fprintf fmt "((%a) %a@,)" picture p transform tr | C.PIName n -> pp_print_string fmt n and path fmt = function C.PAScope p -> fprintf fmt "(%a@,)" path p | C.PAFullCircle -> fprintf fmt "fullcircle" | C.PAHalfCircle -> fprintf fmt "halfcircle" | C.PAQuarterCircle -> fprintf fmt "quartercircle" | C.PAUnitSquare -> fprintf fmt "unitsquare" | C.PATransformed (p,tr) -> fprintf fmt "((%a) %a@,)" path p transform tr | C.PAAppend (p1,j,p2) -> fprintf fmt "%a %a@ %a" path p1 joint j path p2 | C.PACycle (d,j,p) -> fprintf fmt "%a %a %acycle" path p joint j direction d | C.PAConcat (k,j,p) -> fprintf fmt "%a %a@ %a" path p joint j knot k | C.PAKnot k -> knot fmt k | C.PACutAfter (p1, p2) -> fprintf fmt "%a cutafter (%a)@ " path p2 path p1 | C.PACutBefore (p1, p2) -> fprintf fmt "%a cutbefore (%a)@ " path p2 path p1 | C.PABuildCycle l -> fprintf fmt "buildcycle(%a@,)" (Misc.print_list comma path) l | C.PASub (f1, f2, p) -> fprintf fmt "subpath(%a,%a) of %a" num f1 num f2 name p | C.PABBox p -> fprintf fmt "bbox %a" picture p | C.PAName n -> pp_print_string fmt n and joint fmt = function | C.JLine -> fprintf fmt "--" | C.JCurve -> fprintf fmt ".." | C.JCurveNoInflex -> fprintf fmt "..." | C.JTension (a,b) -> fprintf fmt "..tension %a and %a .." float a float b | C.JControls (a,b) -> fprintf fmt "..controls %a and %a .." point a point b and direction fmt = function | C.NoDir -> () | C.Vec p -> fprintf fmt "{%a}" point p (* Why there is not the same thing than in Num?*) | C.Curl f -> fprintf fmt "{curl %a}" float f and knot fmt (d1,p,d2) = fprintf fmt "%a%a%a" direction d1 point p direction d2 and dash fmt = function | C.DEvenly -> fprintf fmt "evenly" | C.DWithdots -> fprintf fmt "withdots" | C.DScaled (s, d) -> fprintf fmt "%a scaled %a" dash d num s | C.DShifted (p, d) -> fprintf fmt "%a shifted %a" dash d point p | C.DPattern l -> fprintf fmt "dashpattern("; List.iter (fun p -> let p,n = match p with C.On n -> "on", n | C.Off n -> "off", n in fprintf fmt "%s %a " p num n) l; fprintf fmt ")" and pen fmt = function | C.PenCircle -> fprintf fmt "pencircle" | C.PenSquare -> fprintf fmt "pensquare" | C.PenFromPath p -> fprintf fmt "makepen (%a@,)" path p | C.PenTransformed (p,tr) -> fprintf fmt "%a %a" pen p transform tr and command fmt = function | C.CDraw (pa, c, pe, dashed) -> fprintf fmt "@[draw@ %a@,%a@,%a@,%a;@]@\n" path pa (print_option " withcolor " color) c (print_option " withpen " pen) pe (print_option " dashed " dash) dashed | C.CDrawArrow (pa, c, pe, dashed) -> fprintf fmt "drawarrow %a%a%a%a;@\n" path pa (print_option " withcolor " color) c (print_option " withpen " pen) pe (print_option " dashed " dash) dashed | C.CFill (pa, c) -> fprintf fmt "fill %a%a;@\n" path pa (print_option " withcolor " color) c | C.CLabel (pic,pos,p) -> fprintf fmt "label%a(%a,@ %a); @\n" position pos picture pic point p | C.CDotLabel (pic,pos,p) -> fprintf fmt "@[dotlabel%a(%a,@ %a);@]@\n" position pos picture pic point p | C.CDrawPic p -> fprintf fmt "draw %a;@\n" picture p | C.CSeq l -> List.iter (fun c -> command fmt c) l | C.CDeclPath (n, p) -> fprintf fmt "path %s ;@\n%s = %a;@\n" n n path p | C.CDeclPoint (n, p) -> fprintf fmt "pair %s ;@\n%s = %a;@\n" n n point p | C.CDeclNum (n, nm) -> fprintf fmt "numeric %s ;@\n%s = %a;@\n" n n num nm | C.CSimplePic (pn1, pexpr) -> fprintf fmt "picture %s;@\n" pn1; fprintf fmt "%s := %a;@\n" pn1 picture pexpr; | C.CDefPic (pic, cmd) -> (* Declpic (savepic, currentpicture); * Assign (currentpicture, nullpicture); * cmd; * Assign (pic, currentpicture); * Assign (currentpicture, savepic) *) let savepic = Name.picture () in fprintf fmt "picture %s, %s ;@\n" savepic pic; fprintf fmt "%s = currentpicture;@\n" savepic; fprintf fmt "currentpicture := nullpicture;@\n"; command fmt cmd; fprintf fmt "%s = currentpicture;@\n" pic; fprintf fmt "currentpicture := %s;@\n" savepic | C.CDefTrans (n,t) -> fprintf fmt "transform %s ;@\n\ xpart %s = %a;@\n\ ypart %s = %a;@\n\ xxpart %s = %a;@\n\ xypart %s = %a;@\n\ yxpart %s = %a;@\n\ yypart %s = %a;@\n@." n n num t.C.x0 n num t.C.y0 n num t.C.xx n num t.C.xy n num t.C.yx n num t.C.yy | C.CClip (pic,pth) -> fprintf fmt "clip %s to %a;@\n" pic path pth | C.CExternalImage (filename, spec) -> match spec with | `Exact (h,w) -> fprintf fmt "externalfigure \"%s\" xyscaled (%a,%a);@\n" filename num w num h | ((`None as spec) | (`Height _ as spec)| (`Width _ as spec)| (`Inside _ as spec)) -> let fh,fw = externalimage_dimension filename in let printext h w = fprintf fmt "externalfigure \"%s\" xyscaled (%a,%a);@\n" filename num w num h in match spec with | `None -> printext (C.F fh) (C.F fw) | `Height h -> printext h (C.NMult (C.F (fw/.fh),h)) | `Width w -> printext (C.NMult (C.F (fh/.fw),w)) w | `Inside (h,w) -> let w = C.NMin (C.NMult (h,C.F (fw/.fh)),w) in printext (C.NMult (C.F (fh/.fw),w)) w mlpost-0.8.1/_tags0000644000443600002640000000101211365367177013233 0ustar kanigdemons<*.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 mlpost-0.8.1/metaPath.ml0000644000443600002640000000762411365367177014327 0ustar kanigdemons(**************************************************************************) (* *) (* 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 S = Point open Types module BaseDefs = struct type direction = Types.direction let vec = mkVec let curl = mkCurl let noDir = mkNoDir type joint = Types.joint let jLine = mkJLine let jCurve = mkJCurve let jCurveNoInflex = mkJCurveNoInflex let jTension = mkJTension let jControls = mkJControls type knot = Types.knot (* the intention is to add new knots in front, * i. e. the list has to be reversed for printing *) let of_path p = mkMPAofPA p let of_metapath p = mkPAofMPA p let to_path = of_metapath let to_metapath = of_path let start k = mkMPAKnot k let metacycle d j p = mkMPACycle d j p let fullcircle = mkPAFullCircle let halfcircle = mkPAHalfCircle let quartercircle = mkPAQuarterCircle let unitsquare = mkPAUnitSquare let transform tr p = List.fold_left mkPATransformed p tr let cut_after p1 p2 = mkPACutAfter p1 p2 let cut_before p1 p2 = mkPACutBefore p1 p2 let build_cycle l = mkPABuildCycle l let subpath (f1: float) (f2: float) p = mkPASub (mkF f1) (mkF f2) p let point (f: float) p = mkPTPointOf (mkF f) p let direction (f: float) p = mkPTDirectionOf (mkF f) p let pointn (n: num) p = mkPTPointOf n p let directionn (n: num) p = mkPTDirectionOf n p let subpathn (n1: num) (n2: num) p = mkPASub n1 n2 p let length p = mkNLength p let defaultjoint = jCurve let defaultdir = noDir end include BaseDefs type t = metapath type path = Types.path let knotp ?(l=defaultdir) ?(r=defaultdir) p = Types.mkKnot l p r let knot ?(l) ?(r) ?(scale) p = knotp ?l (S.p ?scale p) ?r let knotn ?(l) ?(r) p = knotp ?l (S.pt p) ?r let knotlist = List.map (fun (x,y,z) -> Types.mkKnot x y z) let cycle ?(dir=defaultdir) ?(style=defaultjoint) p = metacycle dir style p let concat ?(style=defaultjoint) p k = mkMPAConcat k style p (* construct a path with a given style from a knot list *) let pathk ?(style) = function | [] -> failwith "empty path is not allowed" | (x::xs) -> List.fold_left (fun p knot -> concat ?style p knot) (start x) xs let pathp ?(style) l = pathk ?style (List.map (knotp) l) let pathn ?(style) l = pathp ?style (List.map (Point.pt) l) let path ?(style) ?(scale) l = let sc = S.ptlist ?scale in pathp ?style (sc l) (* construct a path with knot list and joint list *) let jointpathk lp lj = try List.fold_left2 (fun acc j k -> mkMPAConcat k j acc) (start (List.hd lp)) lj (List.tl lp) with Invalid_argument _ -> invalid_arg "jointpathk : the list of knot must \ be one more than the list of join" let jointpathp lp lj = jointpathk (List.map (knotp) lp) lj let jointpathn lp lj = jointpathk (List.map knotn lp) lj let jointpath ?(scale) lp lj = jointpathk (List.map (knot ?scale) lp) lj let append ?(style=defaultjoint) p1 p2 = mkMPAAppend p1 style p2 mlpost-0.8.1/legend.ml0000755000443600002640000000364111365367177014020 0ustar kanigdemons(**************************************************************************) (* *) (* 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 Command open Box open Color let rec mklegend ensstroke colstroke fill vb1 = function |[] -> set_fill fill (set_stroke ensstroke ( box (tabularl ~hpadding:(Num.bp 10.) ~vpadding:(Num.bp 10.) (List.rev vb1)))) |(col,text)::res -> let c = set_fill col (set_stroke colstroke ( empty ~width:(Num.bp 20.) ~height:(Num.bp 10.) ())) in mklegend ensstroke colstroke fill ([c;tex text]::vb1) res let legend ?ensstroke ?colstroke ?fill l = let ensstroke = match ensstroke with |None-> Color.white |Some i -> i in let colstroke = match colstroke with |None-> Color.white |Some i -> i in let fill = match fill with |None-> Color.white |Some i -> i in Picture.make (Box.draw (mklegend ensstroke colstroke fill [] l)) mlpost-0.8.1/compiled_types.ml0000644000443600002640000000763511365367177015606 0ustar kanigdemons(**************************************************************************) (* *) (* 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 = | F of float | NXPart of point | NYPart of point | NAdd of num * num | NSub of num * num | NMult of num * num | NDiv of num * num | NMax of num * num | NMin of num * num | NGMean of num * num | NName of name | NLength of path | NIfnullthenelse of num * num * num and point = | PTPair of num * num | PTPicCorner of picture * Types.corner | PTPointOf of num * path | PTDirectionOf of num * path | PTAdd of point * point | PTSub of point * point | PTMult of num * point | PTRotated of float * point | PTTransformed of point * transform | PTName of name 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 = { xx : num; yx : num; xy : num; yy : num; x0 : num; y0 : num; } and transform = | TRRotated of float | TRScaled of num | TRShifted of point | TRSlanted of num | TRXscaled of num | TRYscaled of num | TRZscaled of point | TRReflect of point * point | TRRotateAround of point * float | TRName of 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.1/tests.ml0000644000443600002640000004422511365367177013724 0ustar kanigdemons(**************************************************************************) (* *) (* 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_adv let rec bin = function | 0 -> Node (0, []) | n -> let (Node (_,l) as t) = bin (n-1) in Node (n, t :: l) let to_box n = Box.tex (sprintf "${2^{%d}}$" n), n let t = map to_box (bin 4) let t = Box.place ~width:(fun (z,_) -> Box.width z) ~height:(fun (z,_) -> Box.height z) ~set_pos:(fun p (z,n) -> Box.center p z, n) t let adv_fig = let (++) = Command.(++) in draw fst t ++ (fold (++) Command.nop (gen_draw_arrows Command.nop ~style:(fun a b -> Helpers.draw_simple_arrow a b) ~corner:(fun d (z,_) -> Box.corner d z) t)) open Tree open Box (* 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:`North [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:`West [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:`Northeast (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:`North ~stroke:(Some Color.red) ~dx:(bp 2.) ~dy:(bp 2.) [vbox ~padding:(bp 4.) ~pos:`East [tex "A"; tex "BC"; tex "D"]; vbox ~padding:(bp 4.) ~pos:`West [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:`West (Picture.tex "Pr") (Point.p (f /. (-4.),0.)) ; label ~pos:`East (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 (sub t1 bl) in let b2 = nth 0 (nth 0 (nth 1 (sub t2 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)) [`South, "0", 0.; `Northeast, "1", 1. ; `Southwest, "2", 2. ; `North, "3", 3. ; `West, "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:`West (Picture.tex "ulcorner") (Picture.ulcorner pic); Command.dotlabel ~pos:`West (Picture.tex "llcorner") (Picture.llcorner pic); Command.dotlabel ~pos:`East (Picture.tex "urcorner") (Picture.urcorner pic); Command.dotlabel ~pos:`East (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 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)), `North, 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 = [ grid_with_padding; adv_fig; grid_with_padding_2; rotatedbox; assia_schema; hbox1; hbox2; bresenham0; simple_box; block1; hvbox; why_platform;d2; block2; vblock1; yannick Box.Rect; yannick Box.Patatoid; yannick Box.Patatoid2; d1; proval; d2sq; d2hsq; d2s; d2c; cheno011; d3; d4; d7; (* recursion *) d11; d12 ; farey 17; (* other *) florence; Box.draw shapes1; Box.draw shapes2; d14; d13; d5; (* d6 *) ] 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.1/diag.ml0000644000443600002640000001163511365367177013465 0ustar kanigdemons(**************************************************************************) (* *) (* 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.1/mlpost_concrete.mlpack0000644000443600002640000000074411365367177016617 0ustar kanigdemonsSignature Num Point MetaPath Path Pen Dash Color Brush Box Transform Picture Arrow Command Helpers Tree Tree_adv Diag Plot Real_plot Shapes Misc Metapost MPprint Generate Radar Hist Legend Cairost Concrete Concrete_types Print Types Compile Compiled_types Duplicate Hashcons Picture_lib Spline Spline_lib Fonts T1disasm Tfm Dvi Dviinterp Matrix Point_lib Compute Pfb_lexer Pfb_parser Map_lexer Map_parser Dev_save Gentex LookForTeX Unionfind Metapath_lib Ctypes Metapost_tool Metric mlpost-0.8.1/types.ml0000644000443600002640000006226511365367177013732 0ustar kanigdemons(**************************************************************************) (* *) (* 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 name = string include Concrete_types type corner = [ | `Northwest | `Northeast | `Southwest | `Southeast | `Upleft | `Upright | `Lowleft | `Lowright | `Upperleft | `Upperright | `Lowerleft | `Lowerright | `Topleft | `Topright | `Bottomleft | `Bottomright ] type corner_red = [ | `Northwest | `Northeast | `Southwest | `Southeast ] type hposition = [ `Center | `West | `East | `Left | `Right ] type vposition = [ `Center | `North | `South | `Top | `Bot (** deprecated *) | `Bottom ] type hposition_red = [ `Center | `West | `East ] type vposition_red = [ `Center | `North | `South ] type position = [ | hposition | vposition | corner ] type position_red = [ | hposition_red | vposition_red | corner_red ] open Hashcons type num_node = | F of float | NXPart of point | NYPart of point | NAdd of num * num | NSub of num * num | NMult of num * num | NDiv of num * num | NMax of num * num | NMin of num * num | NGMean of num * num | NLength of path | NIfnullthenelse of num * num * num and num = num_node hash_consed and point_node = | PTPair of num * num | PTPicCorner of commandpic * corner | PTPointOf of num * path | PTDirectionOf of num * path | PTAdd of point * point | PTSub of point * point | PTMult of num * point | PTRotated of float * point | PTTransformed of point * transform and point = point_node hash_consed and on_off_node = | On of num | Off of num and on_off = on_off_node hash_consed and direction_node = | Vec of point | Curl of float | NoDir and direction = direction_node hash_consed and joint_node = | JLine | JCurve | JCurveNoInflex | JTension of float * float | JControls of point * point and joint = joint_node hash_consed and knot_node = { knot_in : direction ; knot_p : point ; knot_out : direction } and knot = knot_node hash_consed and metapath_node = | MPAConcat of knot * joint * metapath | MPAKnot of knot | MPAAppend of metapath * joint * metapath | MPAofPA of path (*| MPATransformed of metapath * transform*) and metapath = metapath_node hash_consed and path_node = | PAofMPA of metapath | MPACycle of direction * joint * metapath | PAFullCircle | PAHalfCircle | PAQuarterCircle | PAUnitSquare | PATransformed of path * transform | PACutAfter of path * path | PACutBefore of path * path | PABuildCycle of path list | PASub of num * num * path | PABBox of commandpic and path = path_node hash_consed and matrix = { xx : num; yx : num; xy : num; yy : num; x0 : num; y0 : num; } and transform_node = | TRRotated of float | TRScaled of num | TRShifted of point | TRSlanted of num | TRXscaled of num | TRYscaled of num | TRZscaled of point | TRReflect of point * point | TRRotateAround of point * float | TRMatrix of matrix and transform = transform_node hash_consed and dash_node = | DEvenly | DWithdots | DScaled of num * dash | DShifted of point * dash | DPattern of on_off list and dash = dash_node hash_consed and pen_node = | PenCircle | PenSquare | PenFromPath of path | PenTransformed of pen * transform and pen = pen_node hash_consed and picture_node = | PITex of string | PITransformed of commandpic * transform | PIClip of commandpic * path and picture = picture_node hash_consed and command_node = | CDraw of path * brush | CFill of path * color option | CLabel of commandpic * position * point | CDotLabel of commandpic * position * point | 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 command = command_node hash_consed and commandpic_node = | Picture of picture | Command of command | Seq of commandpic list and commandpic = commandpic_node hash_consed and brush_node = {pen : pen option; dash : dash option; color : color option} and brush = brush_node hash_consed let hash_float = Hashtbl.hash let hash_piccorner = Hashtbl.hash let hash_string = Hashtbl.hash let combine n acc = acc * 65599 + n let combine2 n acc1 acc2 = combine n (combine acc1 acc2) let combine3 n acc1 acc2 acc3 = combine n (combine acc1 (combine acc2 acc3)) let combine4 n acc1 acc2 acc3 acc4 = combine n (combine3 acc1 acc2 acc3 acc4) let num = function | F f -> combine 1 (hash_float f) | NXPart p -> combine 2 p.hkey | NYPart p -> combine 3 p.hkey | NAdd(n,m) -> combine2 4 n.hkey m.hkey | NSub(n,m) -> combine2 5 n.hkey m.hkey | NMult(n,m) -> combine2 6 n.hkey m.hkey | NDiv(n,m) -> combine2 7 n.hkey m.hkey | NMax(n,m) -> combine2 8 n.hkey m.hkey | NMin(n,m) -> combine2 9 n.hkey m.hkey | NGMean(n,m) -> combine2 10 n.hkey m.hkey | NLength p -> combine 11 p.hkey | NIfnullthenelse (n,n1,n2) -> combine3 12 n.hkey n1.hkey n2.hkey let point = function | PTPair(n,m) -> combine2 12 n.hkey m.hkey | PTPicCorner(p,pc) -> combine2 13 p.hkey (hash_piccorner pc) | PTPointOf(f,p) -> combine2 14 (hash_float f) p.hkey | PTDirectionOf(f,p) -> combine2 15 (hash_float f) p.hkey | PTAdd(p,q) -> combine2 16 p.hkey q.hkey | PTSub(p,q) -> combine2 17 p.hkey q.hkey | PTMult(n,q) -> combine2 18 n.hkey q.hkey | PTRotated(f,p) -> combine2 19 (hash_float f) p.hkey | PTTransformed(p,tr) -> combine2 20 p.hkey tr.hkey let on_off = function | On n -> combine 65 n.hkey | Off n -> combine 66 n.hkey let direction = function | Vec p -> combine 61 p.hkey | Curl f -> combine 62 (hash_float f) | NoDir -> 63 let joint = function | JLine -> 67 | JCurve -> 68 | JCurveNoInflex -> 69 | JTension(f1,f2) -> combine2 70 (hash_float f1) (hash_float f2) | JControls(p1,p2) -> combine2 71 p1.hkey p2.hkey let knot k = combine3 64 k.knot_in.hkey k.knot_p.hkey k.knot_out.hkey let metapath = function | MPAConcat(k,j,p) -> combine3 85 k.hkey j.hkey p.hkey | MPAAppend(p1,j,p2) -> combine3 86 p1.hkey j.hkey p2.hkey | MPAofPA p -> combine 87 p.hkey | MPAKnot k -> combine 88 k.hkey let path = function | PAofMPA p -> combine 89 p.hkey | MPACycle(d,j,p) -> combine3 90 d.hkey j.hkey p.hkey | PAFullCircle -> 24 | PAHalfCircle -> 25 | PAQuarterCircle -> 26 | PAUnitSquare -> 27 | PATransformed(p,tr) -> combine2 28 p.hkey tr.hkey | PACutAfter(p,q) -> combine2 32 p.hkey q.hkey | PACutBefore(p,q) -> combine2 33 p.hkey q.hkey | PABuildCycle l -> List.fold_left (fun acc p -> combine2 35 acc p.hkey) 34 l | PASub(f1,f2,p) -> combine3 36 (hash_float f1) (hash_float f2) p.hkey | PABBox p -> combine 37 p.hkey let transform = function | TRRotated f -> combine 52 (hash_float f) | TRScaled n -> combine 53 n.hkey | TRShifted p -> combine 57 p.hkey | TRSlanted n -> combine 54 n.hkey | TRXscaled n -> combine 55 n.hkey | TRYscaled n -> combine 56 n.hkey | TRZscaled p -> combine 58 p.hkey | TRReflect(p,q) -> combine2 59 p.hkey q.hkey | TRRotateAround(p,q) -> combine2 60 p.hkey (hash_float q) | TRMatrix m -> List.fold_left (fun acc n -> combine2 63 acc n.hkey) 61 [m.x0;m.y0;m.xx;m.xy;m.yx;m.yy] let picture = function | PITex s -> combine 38 (hash_string s) | PITransformed(p,tr) -> combine2 40 p.hkey tr.hkey | PIClip(p,q) -> combine2 42 p.hkey q.hkey let commandpic = function | Picture pic -> combine 91 pic.hkey | Command c -> combine 92 c.hkey | Seq l -> List.fold_left (fun acc t -> combine2 93 acc t.hkey) 94 l let dash = function | DEvenly -> 72 | DWithdots -> 73 | DScaled(f,d) -> combine2 74 (hash_float f) d.hkey | DShifted(p,d) -> combine2 75 p.hkey d.hkey | DPattern l -> List.fold_left (fun acc o -> combine2 76 acc o.hkey) 77 l let pen = function | PenCircle -> 78 | PenSquare -> 79 | PenFromPath p -> combine 80 p.hkey | PenTransformed(p,tr) -> combine2 81 p.hkey tr.hkey let hash_opt f = function | None -> 83 | Some o -> combine 84 (f o) let hash_key x = x.hkey let hash_color = Hashtbl.hash let hash_position = Hashtbl.hash let hash_spec_image = Hashtbl.hash let command = function | CDraw(pa,b) -> combine2 43 pa.hkey b.hkey | CFill(p,c) -> combine2 46 p.hkey (hash_color c) | CLabel(pic,pos,poi) -> combine3 47 pic.hkey (hash_position pos) poi.hkey | CDotLabel(pic,pos,poi) -> combine3 48 pic.hkey (hash_position pos) poi.hkey | CExternalImage (filename,spec) -> combine2 52 (hash_string filename) (hash_spec_image spec) let brush b = combine3 85 (hash_opt hash_color b.color) (hash_opt hash_key b.pen) (hash_opt hash_key b.dash) (** equality *) (* equality of floats with correct handling of nan *) let eq_float (f1:float) (f2:float) = Pervasives.compare f1 f2 == 0 (* we enforce to use physical equality only on hash-consed data of the same type *) let eq_hashcons (x:'a hash_consed) (y:'a hash_consed) = x == y let rec eq_hashcons_list (x:'a hash_consed list) (y:'a hash_consed list) = match x,y with | [], [] -> true | h1::t1,h2::t2 -> h1 == h2 && eq_hashcons_list t1 t2 | _ -> false let eq_opt f o1 o2 = match o1,o2 with | None,None -> true | Some x1, Some x2 -> f x1 x2 | _ -> false let eq_color c1 c2 = Pervasives.compare c1 c2 = 0 let eq_pen_node p1 p2 = match p1, p2 with | PenCircle, PenCircle | PenSquare, PenSquare -> true | PenFromPath p1, PenFromPath p2 -> eq_hashcons p1 p2 | PenTransformed(p1,tr1), PenTransformed(p2,tr2) -> eq_hashcons p1 p2 && eq_hashcons tr1 tr2 | _ -> false let eq_dash_node d1 d2 = match d1, d2 with | DEvenly, DEvenly | DWithdots, DWithdots -> true | DScaled(f1,d1), DScaled(f2,d2) -> eq_hashcons f1 f2 && eq_hashcons d1 d2 | DShifted(p1,d1), DShifted(p2,d2) -> eq_hashcons p1 p2 && eq_hashcons d1 d2 | DPattern l1, DPattern l2 -> eq_hashcons_list l1 l2 | _ -> false let eq_brush_node b1 b2 = eq_opt eq_color b1.color b2.color && eq_opt eq_hashcons b1.pen b2.pen && eq_opt eq_hashcons b1.dash b2.dash let eq_on_off o1 o2 = match o1,o2 with | Off n1, Off n2 | On n1, On n2 -> eq_hashcons n1 n2 | _ -> false let eq_position (p1:position) (p2:position) = p1 == p2 (* correct because this type contains only constants *) let eq_num_node n1 n2 = match n1,n2 with | F f1, F f2 -> eq_float f1 f2 | NXPart p1, NXPart p2 | NYPart p1, NYPart p2 -> eq_hashcons p1 p2 | NAdd(n11,n12),NAdd(n21,n22) | NSub(n11,n12),NSub(n21,n22) | NMult(n11,n12),NMult(n21,n22) | NDiv(n11,n12),NDiv(n21,n22) | NMax(n11,n12),NMax(n21,n22) | NMin(n11,n12),NMin(n21,n22) | NGMean(n11,n12),NGMean(n21,n22) -> eq_hashcons n11 n21 && eq_hashcons n12 n22 | NLength p1, NLength p2 -> eq_hashcons p1 p2 | _ -> false let eq_point_node p1 p2 = match p1,p2 with | PTPair(n11,n12),PTPair(n21,n22) -> eq_hashcons n11 n21 && eq_hashcons n12 n22 | PTPicCorner(pic1,corn1), PTPicCorner(pic2,corn2) -> eq_hashcons pic1 pic2 && eq_position (corn1 :> position) (corn2 :> position) | PTPointOf(n1,p1), PTPointOf(n2,p2) | PTDirectionOf(n1,p1), PTDirectionOf(n2,p2) -> eq_hashcons n1 n2 && eq_hashcons p1 p2 | PTAdd(p11,p12),PTAdd(p21,p22) | PTSub(p11,p12),PTSub(p21,p22) -> eq_hashcons p11 p21 && eq_hashcons p12 p22 | PTMult(n1,p1),PTMult(n2,p2) -> eq_hashcons n1 n2 && eq_hashcons p1 p2 | PTRotated(f1,p1),PTRotated(f2,p2) -> eq_float f1 f2 && eq_hashcons p1 p2 | PTTransformed(p1,tr1), PTTransformed(p2,tr2) -> eq_hashcons p1 p2 && eq_hashcons tr1 tr2 | _ -> false let eq_metapath_node p1 p2 = match p1,p2 with | MPAConcat(k1,j1,p1),MPAConcat(k2,j2,p2) -> eq_hashcons k1 k2 && eq_hashcons j1 j2 && eq_hashcons p1 p2 | MPAKnot(k1), MPAKnot(k2) -> eq_hashcons k1 k2 | MPAAppend(p11,j1,p12),MPAAppend(p21,j2,p22) -> eq_hashcons p11 p21 && eq_hashcons j1 j2 && eq_hashcons p12 p22 | MPAofPA p1, MPAofPA p2 -> eq_hashcons p1 p2 | _ -> false let eq_path_node p1 p2 = match p1,p2 with | PAofMPA p1, PAofMPA p2 -> eq_hashcons p1 p2 | MPACycle(d1,j1,p1),MPACycle(d2,j2,p2) -> eq_hashcons d1 d2 && eq_hashcons j1 j2 && eq_hashcons p1 p2 | PAFullCircle, PAFullCircle | PAHalfCircle, PAHalfCircle | PAQuarterCircle, PAQuarterCircle | PAUnitSquare, PAUnitSquare -> true | PATransformed(p1,tr1),PATransformed(p2,tr2) -> eq_hashcons p1 p2 && eq_hashcons tr1 tr2 | PACutAfter(p11,p12),PACutAfter(p21,p22) | PACutBefore(p11,p12),PACutBefore(p21,p22) -> eq_hashcons p11 p21 && eq_hashcons p12 p22 | PABuildCycle(l1),PABuildCycle(l2) -> eq_hashcons_list l1 l2 | PASub(f11,f12,p1), PASub(f21,f22,p2) -> eq_hashcons f11 f21 && eq_hashcons f12 f22 && eq_hashcons p1 p2 | PABBox(p1), PABBox(p2) -> eq_hashcons p1 p2 | _ -> false let eq_picture_node p1 p2 = match p1,p2 with | PITex s1, PITex s2 -> (* it actually happens that the same text appears twice *) s1<>"" && s1=s2 | PITransformed(p1,tr1), PITransformed(p2,tr2) -> eq_hashcons p1 p2 && eq_hashcons tr1 tr2 | PIClip(pi1,pa1), PIClip(pi2,pa2) -> eq_hashcons pi1 pi2 && eq_hashcons pa1 pa2 | _ -> false let eq_transform_node t1 t2 = match t1,t2 with | TRRotated f1, TRRotated f2 -> eq_float f1 f2 | TRScaled n1, TRScaled n2 | TRSlanted n1, TRSlanted n2 | TRXscaled n1, TRXscaled n2 | TRYscaled n1, TRYscaled n2 -> eq_hashcons n1 n2 | TRShifted p1, TRShifted p2 | TRZscaled p1, TRZscaled p2 -> eq_hashcons p1 p2 | TRReflect(p11,p12), TRReflect(p21,p22) -> eq_hashcons p11 p21 && eq_hashcons p12 p22 | TRRotateAround(p1,f1), TRRotateAround(p2,f2) -> eq_hashcons p1 p2 && eq_float f1 f2 | TRMatrix m1, TRMatrix m2 -> eq_hashcons m1.x0 m2.x0 && eq_hashcons m1.y0 m2.y0 && eq_hashcons m1.xx m2.xx && eq_hashcons m1.xy m2.xy && eq_hashcons m1.yx m2.yx && eq_hashcons m1.yy m2.yy | _ -> false let eq_knot_node k1 k2 = eq_hashcons k1.knot_in k2.knot_in && eq_hashcons k1.knot_p k2.knot_p && eq_hashcons k1.knot_out k2.knot_out let eq_joint_node j1 j2 = match j1,j2 with | JLine, JLine | JCurve, JCurve | JCurveNoInflex, JCurveNoInflex -> true | JTension(f11,f12), JTension(f21,f22) -> eq_float f11 f21 && eq_float f12 f22 | JControls(p11,p12), JControls(p21,p22) -> eq_hashcons p11 p21 && eq_hashcons p12 p22 | _ -> false let eq_direction_node d1 d2 = match d1,d2 with | Vec p1, Vec p2 -> eq_hashcons p1 p2 | Curl f1, Curl f2 -> eq_float f1 f2 | NoDir, NoDir -> true | _ -> false let eq_command_node c1 c2 = match c1,c2 with | CDraw(p1,b1), CDraw(p2,b2) -> eq_hashcons p1 p2 && eq_hashcons b1 b2 | CFill(p1,c1), CFill(p2,c2) -> eq_hashcons p1 p2 && eq_opt eq_color c1 c2 | CLabel(pic1,pos1,poi1), CLabel(pic2,pos2,poi2) | CDotLabel(pic1,pos1,poi1), CDotLabel(pic2,pos2,poi2) -> eq_hashcons pic1 pic2 && eq_position pos1 pos2 && eq_hashcons poi1 poi2 | _ -> false let eq_commandpic_node p1 p2 = match p1, p2 with | Picture p1, Picture p2 -> eq_hashcons p1 p2 | Command p1, Command p2 -> eq_hashcons p1 p2 | Seq l1, Seq l2 -> eq_hashcons_list l1 l2 | _ -> false (* smart constructors *) (* num *) let unsigned f x = (f x) land 0x3FFFFFFF module HashNum = Hashcons.Make(struct type t = num_node let equal = eq_num_node let hash = unsigned num end) let hashnum_table = HashNum.create 257;; let hashnum = HashNum.hashcons hashnum_table let mkF f = hashnum (F f) let mkNAdd n1 n2 = hashnum (NAdd(n1,n2)) let mkNSub n1 n2 = hashnum (NSub(n1,n2)) let mkNMult n1 n2 = hashnum (NMult(n1,n2)) let mkNDiv n1 n2 = hashnum (NDiv(n1,n2)) let mkNMax n1 n2 = hashnum (NMax(n1,n2)) let mkNMin n1 n2 = hashnum (NMin(n1,n2)) let mkNGMean n1 n2 = hashnum (NGMean(n1,n2)) let mkNXPart p = hashnum (NXPart p) let mkNYPart p = hashnum (NYPart p) let mkNLength p = hashnum (NLength p) let mkNIfnullthenelse p n1 n2 = hashnum (NIfnullthenelse (p,n1,n2)) (* point *) module HashPoint = Hashcons.Make(struct type t = point_node let equal = eq_point_node let hash = unsigned point end) let hashpoint_table = HashPoint.create 257;; let hashpoint = HashPoint.hashcons hashpoint_table let mkPTPair f1 f2 = hashpoint (PTPair(f1,f2)) let mkPTAdd p1 p2 = hashpoint (PTAdd(p1,p2)) let mkPTSub p1 p2 = hashpoint (PTSub(p1,p2)) let mkPTMult x y = hashpoint (PTMult(x,y)) let mkPTRotated x y = hashpoint (PTRotated(x,y)) let mkPTTransformed x y = hashpoint (PTTransformed(x,y)) let mkPTPointOf f p = hashpoint (PTPointOf(f,p)) let mkPTDirectionOf f p = hashpoint (PTDirectionOf(f,p)) let mkPTPicCorner x y = hashpoint (PTPicCorner(x,y)) (* transform *) module HashTransform = Hashcons.Make(struct type t = transform_node let equal = eq_transform_node let hash = unsigned transform end) let hashtransform_table = HashTransform.create 257;; let hashtransform = HashTransform.hashcons hashtransform_table let mkTRScaled n = hashtransform (TRScaled n) let mkTRXscaled n = hashtransform (TRXscaled n) let mkTRYscaled n = hashtransform (TRYscaled n) let mkTRZscaled pt = hashtransform (TRZscaled pt) let mkTRRotated f = hashtransform (TRRotated f) let mkTRShifted pt = hashtransform (TRShifted pt) let mkTRSlanted n = hashtransform (TRSlanted n) let mkTRReflect pt1 pt2 = hashtransform (TRReflect(pt1,pt2)) let mkTRRotateAround pt f = hashtransform (TRRotateAround(pt,f)) let mkTRMatrix m = hashtransform (TRMatrix m) (* knot *) module HashKnot = Hashcons.Make(struct type t = knot_node let equal = eq_knot_node let hash = unsigned knot end) let hashknot_table = HashKnot.create 257;; let hashknot = HashKnot.hashcons hashknot_table let mkKnot d1 p d2 = hashknot { knot_in = d1; knot_p = p; knot_out = d2 } (* metapath *) module HashMetaPath = Hashcons.Make(struct type t = metapath_node let equal = eq_metapath_node let hash = unsigned metapath end) let hashmetapath_table = HashMetaPath.create 257;; let hashmetapath = HashMetaPath.hashcons hashmetapath_table let mkMPAKnot k = hashmetapath (MPAKnot k) let mkMPAConcat k j p2 = hashmetapath (MPAConcat(k,j,p2)) let mkMPAAppend x y z = hashmetapath (MPAAppend (x,y,z)) let mkMPAofPA p = hashmetapath (MPAofPA p) (*val mkMPATransformed : path -> transform -> path*) (* path *) module HashPath = Hashcons.Make(struct type t = path_node let equal = eq_path_node let hash = unsigned path end) let hashpath_table = HashPath.create 257;; let hashpath = HashPath.hashcons hashpath_table let mkPAofMPA p = hashpath (PAofMPA p) let mkPAKnot k = mkPAofMPA (mkMPAKnot k) let mkPAConcat k j p2 = mkPAofMPA (mkMPAConcat k j (mkMPAofPA p2)) let mkMPACycle d j p1 = hashpath (MPACycle (d,j,p1)) let mkPACycle d j p1 = (mkMPACycle d j (mkMPAofPA p1)) let mkPAAppend x y z = mkPAofMPA (mkMPAAppend (mkMPAofPA x) y (mkMPAofPA z)) let mkPAFullCircle = hashpath (PAFullCircle) let mkPAHalfCircle = hashpath (PAHalfCircle) let mkPAQuarterCircle = hashpath (PAQuarterCircle) let mkPAUnitSquare = hashpath (PAUnitSquare) let mkPATransformed x y = hashpath (PATransformed (x,y)) let mkPACutAfter x y = hashpath (PACutAfter (x,y)) let mkPACutBefore x y = hashpath (PACutBefore (x,y)) let mkPABuildCycle l = hashpath (PABuildCycle l) let mkPASub x y z = hashpath (PASub (x,y,z)) let mkPABBox pic = hashpath (PABBox pic) (* joint *) module HashJoint = Hashcons.Make(struct type t = joint_node let equal = eq_joint_node let hash = unsigned joint end) let hashjoint_table = HashJoint.create 257;; let hashjoint = HashJoint.hashcons hashjoint_table let mkJCurve = hashjoint JCurve let mkJLine = hashjoint JLine let mkJCurveNoInflex = hashjoint JCurveNoInflex let mkJTension x y = hashjoint (JTension(x,y)) let mkJControls x y = hashjoint (JControls(x,y)) (* direction *) module HashDir = Hashcons.Make(struct type t = direction_node let equal = eq_direction_node let hash = unsigned direction end) let hashdir_table = HashDir.create 257;; let hashdir = HashDir.hashcons hashdir_table let mkNoDir = hashdir NoDir let mkVec p = hashdir (Vec p) let mkCurl f = hashdir (Curl f) (* picture *) module HashPicture = Hashcons.Make(struct type t = picture_node let equal = eq_picture_node let hash = unsigned picture end) let hashpicture_table = HashPicture.create 257;; let hashpicture = HashPicture.hashcons hashpicture_table let mkPITex s = hashpicture (PITex s) let mkPITransformed x y = hashpicture (PITransformed (x,y)) let mkPIClip p pic = hashpicture (PIClip(p,pic)) (* command *) module HashCommand = Hashcons.Make(struct type t = command_node let equal = eq_command_node let hash = unsigned command end) let hashcommand_table = HashCommand.create 257;; let hashcommand = HashCommand.hashcons hashcommand_table let mkCDraw x y = hashcommand (CDraw(x,y)) let mkCFill x y = hashcommand (CFill(x,y)) let mkCLabel x y z = hashcommand (CLabel(x,y,z)) let mkCDotLabel x y z = hashcommand (CDotLabel(x,y,z)) let mkCExternalImage f s = hashcommand (CExternalImage (f,s)) (* commandPic *) module HashCommandPic = Hashcons.Make (struct type t = commandpic_node let equal = eq_commandpic_node let hash = unsigned commandpic end) let hashcommandpic_table = HashCommandPic.create 257;; let hashcommandpic = HashCommandPic.hashcons hashcommandpic_table let mkPicture p = hashcommandpic (Picture p) let mkCommand p = hashcommandpic (Command p) let mkSeq l = hashcommandpic (Seq l) (* dash *) module HashDash = Hashcons.Make(struct type t = dash_node let equal = eq_dash_node let hash = unsigned dash end) let hashdash_table = HashDash.create 257;; let hashdash = HashDash.hashcons hashdash_table let mkDEvenly = hashdash DEvenly let mkDWithdots = hashdash DWithdots let mkDScaled x y = hashdash (DScaled(x,y)) let mkDShifted x y = hashdash (DShifted(x,y)) let mkDPattern l = hashdash (DPattern l) (* pen *) module HashPen = Hashcons.Make(struct type t = pen_node let equal = eq_pen_node let hash = unsigned pen end) let hashpen_table = HashPen.create 257;; let hashpen = HashPen.hashcons hashpen_table let mkPenCircle = hashpen PenCircle let mkPenSquare = hashpen PenSquare let mkPenFromPath p = hashpen (PenFromPath p) let mkPenTransformed x y = hashpen (PenTransformed(x,y)) (* brush *) module HashBrush = Hashcons.Make(struct type t = brush_node let equal = eq_brush_node let hash = unsigned brush end) let hashbrush_table = HashBrush.create 257;; let hashbrush = HashBrush.hashcons hashbrush_table let mkBrush c p d = hashbrush {pen = p;color=c;dash=d} let opt_def_node def = function | None -> def | Some s -> s.node let opt_def_map f def = function | None -> def | Some s -> f s let mkBrushOpt b c p d = let b = opt_def_node {color = None; pen = None; dash = None} b in let b = opt_def_map (fun x -> {b with color = Some x}) b c in let b = opt_def_map (fun x -> {b with pen = Some x}) b p in let b = opt_def_map (fun x -> {b with dash = Some x}) b d in hashbrush b (* on_off *) module HashOnOff = Hashcons.Make(struct type t = on_off_node let equal = eq_on_off let hash = unsigned on_off end) let hashon_off_table = HashOnOff.create 257;; let hashon_off = HashOnOff.hashcons hashon_off_table let mkOn n = hashon_off (On n) let mkOff n = hashon_off (Off n) let hreduce = function | `Center -> `Center | `Left | `West -> `West | `Right | `East -> `East let vreduce = function | `Center -> `Center | `Top | `North -> `North | `Bot | `Bottom | `South -> `South let corner_reduce = function | `Upleft | `Upperleft | `Topleft | `Northwest -> `Northwest | `Upright | `Upperright | `Topright | `Northeast -> `Northeast | `Lowleft | `Lowerleft | `Bottomleft | `Southwest -> `Southwest | `Lowright | `Lowerright | `Bottomright | `Southeast -> `Southeast let pos_reduce = function | #hposition as p -> hreduce p | #vposition as p -> vreduce p | #corner as p -> corner_reduce p let opposite_position (x: position): position_red = match pos_reduce x with | `Center -> `Center | `West -> `East | `East -> `West | `North -> `South | `South -> `North | `Northwest -> `Southeast | `Northeast -> `Southwest | `Southwest -> `Northeast | `Southeast -> `Northwest let q_verbosity = Queue.create () let add_set_verbosity x = Queue.add x q_verbosity let set_verbosity b = Queue.iter (fun x -> x b) q_verbosity mlpost-0.8.1/backend/0000755000443600002640000000000011365367167013607 5ustar kanigdemonsmlpost-0.8.1/backend/testdvicairo.ml0000644000443600002640000000747011365367177016652 0ustar kanigdemons(**************************************************************************) (* *) (* 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 let ps = ref false let pdf = ref false let svg = ref false let gtk = ref false let png = ref false let calc_dim = ref false let separate_page = ref false let margin = ref 2.54 let trace = ref false let debug = ref false module Saved_device = Dviinterp.Interp(Dev_save.Dev_save) module Cairo_device = Dev_save.Dev_load(Dvicairo.Cairo_device) let format_prefix s max = Printf.sprintf "%s%03i" s let all_output_aux h w x y prefix saved = if !ps then if !debug then printf "PS generation@."; Dvicairo.create_ps h w x y (Cairo_device.replay !trace saved) (prefix^".ps"); if !pdf then if !debug then printf "PDF generation@."; Dvicairo.create_pdf h w x y (Cairo_device.replay !trace saved) (prefix^".pdf"); if !svg then if !debug then printf "SVG generation@."; Dvicairo.create_svg h w x y (Cairo_device.replay !trace saved) (prefix^".svg"); if !png then if !debug then printf "PNG generation@."; Dvicairo.create_png h w x y (Cairo_device.replay !trace saved) (prefix^".png"); if !gtk then if !debug then printf "GTK generation@."; Dvicairo.create_gtk h w x y (Cairo_device.replay !trace saved) prefix let all_output s = let prefix = try Filename.chop_extension s with Invalid_argument _ -> s in let doc = Dvi.read_file s in let saved = Saved_device.load_doc () doc in if !separate_page then let pages = Dev_save.separe_pages saved in let fprefix = format_prefix prefix (Dev_save.nb_pages saved) in let count = ref 0 in List.iter ( function page -> let x_min,y_min,x_max,y_max = Dev_save.get_dimen_first_page page in let w = x_max -. x_min in let h = y_max -. y_min in all_output_aux h w (-.x_min) (-.y_min) (incr(count);fprefix !count) page ) pages else let height = Dvi.get_height_cm doc +. 2. *. !margin in let width = Dvi.get_width_cm doc +. 2. *. !margin in all_output_aux height width !margin !margin prefix saved let options = [("-m",Arg.Set_float margin,"Set the margin (cm) around the pages (2.54 cm = 1 in by default)"); ("--pdf",Arg.Set pdf,"Output in pdf (dviname.pdf)"); ("--ps",Arg.Set ps,"Output in ps (dviname.pdf)"); ("--svg",Arg.Set svg,"Output in svg (dviname.svg)"); (* ("--gtk",Arg.Set gtk,"Output in a gtk window"); ("--png",Arg.Set gtk,"Output in png window (dviname%d.png)");*) (*("--calc_dim",Arg.Set calc_dim,"Don't use the dvi dimension");*) ("--separate_page",Arg.Set separate_page,"Generate one file for each page"); ("--trace",Arg.Set trace,"Trace the bounding box"); ("-v",Arg.Set debug,"Verbose") ] let _ = Arg.parse options all_output "Usage :dvicairo [options] ...\n" mlpost-0.8.1/backend/icairost.ml0000644000443600002640000001035311365367177015761 0ustar kanigdemons(**************************************************************************) (* *) (* 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 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; 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 ...@."; Cairo.surface_finish s; if !info 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 = LookForTeX.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 = LookForTeX.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 mlpost-0.8.1/backend/testspline_lib.ml0000644000443600002640000002013411365367177017162 0ustar kanigdemons(**************************************************************************) (* *) (* 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 = Cairo.point = { x : float ; y : float } let point_of_cm cm = (0.3937 *. 72.) *. cm let two_pi = 8. *. atan 1. let create create_surface height width (draw:Cairo.t -> unit) out_file = let height = point_of_cm height and width = point_of_cm width in 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; Cairo.surface_finish s; 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 draw_control_line cr a b w = Cairo.save cr ; begin Cairo.set_source_rgb cr 0. 0. 1. ; Cairo.set_line_width cr w ; Cairo.move_to cr a.x a.y ; Cairo.line_to cr b.x b.y ; Cairo.stroke cr end ; Cairo.restore cr let draw_point cr col pt = Cairo.save cr ; (match col with |`Green -> Cairo.set_source_rgba cr 0. 1. 0. 0.5 |`Yellow -> Cairo.set_source_rgba cr 0. 1. 1. 0.5 |`Red -> Cairo.set_source_rgba cr 1. 0. 0. 0.5); Cairo.new_path cr ; Cairo.arc cr pt.x pt.y (10. /. 1.25) 0. two_pi ; Cairo.fill cr; Cairo.restore cr let draw_spline cr a b c d = Cairo.save cr ; begin Cairo.move_to cr a.x a.y ; Cairo.curve_to cr b.x b.y c.x c.y d.x d.y ; Cairo.stroke cr ; draw_control_line cr a b 2. ; draw_control_line cr d c 2. ; List.iter (draw_point cr `Red) [a;b;c;d]; end; Cairo.restore cr let ribbon = Spline_lib.create {x=110.;y=20.} {x=310.;y=300.} {x=10.;y= 310.} {x=210.;y=20.} let arc = Spline_lib.create {x=67.;y=129.} {x=260.;y=256.} {x=231.;y=43.} {x=104.;y=47.} let point_dist_min = {x = 100.;y=100.} let _ = Spline_lib.inter_depth := 10 let draw cr = Cairo.set_line_width cr 10. ; (* The first page intersection*) Cairo.save cr; (* Intersection between the ribbon and the arc on the ribbon *) Spline_lib.iter (draw_spline cr) ribbon; Spline_lib.iter (draw_spline cr) arc; List.iter (draw_point cr `Green) (List.map (fun (t,_) -> Spline_lib.abscissa_to_point ribbon t) (Spline_lib.intersection ribbon arc)); Cairo.translate cr 400. 0. ; (* Intersection between the ribbon and the arc on the arc *) Spline_lib.iter (draw_spline cr) ribbon; Spline_lib.iter (draw_spline cr) arc; List.iter (draw_point cr `Green) (List.map (fun (_,t) -> Spline_lib.abscissa_to_point arc t) (Spline_lib.intersection ribbon arc)); Cairo.restore cr; Cairo.show_page cr; (* Nearest point between the ribbon (resp. arc) and the point *) Spline_lib.iter (draw_spline cr) ribbon; Spline_lib.iter (draw_spline cr) arc; draw_point cr `Yellow point_dist_min; draw_point cr `Green (Spline_lib.abscissa_to_point ribbon (Spline_lib.dist_min_point ribbon point_dist_min)); draw_point cr `Green (Spline_lib.abscissa_to_point arc (Spline_lib.dist_min_point arc point_dist_min)); Cairo.show_page cr; (* Nearest point between the ribbon and two different arc *) let ribbon_t1 = Spline_lib.translate ribbon {x=400.;y=0.} in let arc_t3 = Spline_lib.translate arc {x=400.;y=250.} in Spline_lib.iter (draw_spline cr) ribbon_t1; Spline_lib.iter (draw_spline cr) arc; Spline_lib.iter (draw_spline cr) arc_t3; let (t1,t2) = Spline_lib.dist_min_path ribbon_t1 arc in draw_point cr `Green (Spline_lib.abscissa_to_point ribbon_t1 t1); draw_point cr `Green (Spline_lib.abscissa_to_point arc t2); let (t1,t2) = Spline_lib.dist_min_path ribbon_t1 arc_t3 in draw_point cr `Green (Spline_lib.abscissa_to_point ribbon_t1 t1); draw_point cr `Green (Spline_lib.abscissa_to_point arc_t3 t2); Cairo.show_page cr; let arc_t1 = Spline_lib.translate arc {x=400.;y=0.} in let arc_t2 = Spline_lib.translate arc {x=0.;y=250.} in let ribbon_t2 = Spline_lib.translate ribbon {x=0.;y=250.} in Spline_lib.iter (draw_spline cr) ribbon; Spline_lib.iter (draw_spline cr) arc; let (t1,t2) = (Spline_lib.one_intersection ribbon arc) in draw_point cr `Green (Spline_lib.abscissa_to_point ribbon t1); Spline_lib.iter (draw_spline cr) (fst (Spline_lib.split arc_t1 t2)); Spline_lib.iter (draw_spline cr) (snd (Spline_lib.split arc_t2 t2)); Spline_lib.iter (draw_spline cr) (fst (Spline_lib.split ribbon_t1 t1)); Spline_lib.iter (draw_spline cr) (snd (Spline_lib.split ribbon_t2 t1)); Cairo.show_page cr; let segment1 = Spline_lib.create {x=150.;y=50.} {x=50.;y=150.} {x=150.;y=50.} {x=50.;y=150.} in let segment2 = Spline_lib.translate segment1 {y=50.;x=50.} in Spline_lib.iter (draw_spline cr) segment1; Spline_lib.iter (draw_spline cr) segment2; let (t1,t2) = Spline_lib.dist_min_path segment1 segment2 in draw_point cr `Green (Spline_lib.abscissa_to_point segment1 t1); draw_point cr `Green (Spline_lib.abscissa_to_point segment2 t2); Cairo.show_page cr; let segment1 = Spline_lib.create {x=150.;y=50.} {x=50.;y=150.} {x=150.;y=50.} {x=50.;y=150.} in let segment2 = Spline_lib.translate segment1 {y=50.;x=75.} in Spline_lib.iter (draw_spline cr) segment1; Spline_lib.iter (draw_spline cr) segment2; let (t1,t2) = Spline_lib.dist_min_path segment1 segment2 in draw_point cr `Green (Spline_lib.abscissa_to_point segment1 t1); draw_point cr `Green (Spline_lib.abscissa_to_point segment2 t2); Cairo.show_page cr; (* let texs = Gentex.create "" ["$\\frac{a}{b}$";"Bonjour";"$\\sqrt{1+2+3}^x_i$"] in*) let label = ["Hello World"; "$\\frac{a^3}{b}$"; "$A^3_i$"; "$\\sqrt{1+2+3}^x_i$"; "\\parbox{3cm}{Haut\\newline Bas}"; "\\newlength{\\hautw}\\settowidth{\\hautw}{Haut}\\parbox{\\hautw}{Haut\\newline Bas}" ] in let texs = Gentex.create "" label in let box draw_bases tex = let (x_min,y_min,x_max,y_max) = Gentex.get_dimen_pt tex in Cairo.save cr; Cairo.set_source_rgb cr 0. 0. 1. ; Cairo.set_line_width cr 0.5 ; Cairo.move_to cr x_min y_min ; Cairo.line_to cr x_min y_max ; Cairo.line_to cr x_max y_max ; Cairo.line_to cr x_max y_min ; Cairo.line_to cr x_min y_min ; Cairo.stroke cr; if draw_bases then List.iter (fun x -> Cairo.set_source_rgb cr 0. 1. 0. ; Cairo.move_to cr x_min x; Cairo.line_to cr x_max x; Cairo.stroke cr) (Gentex.get_bases_pt tex); Cairo.restore cr; Gentex.draw cr tex in Cairo.translate cr 50. 50.; let draw_all tx ty = Cairo.save cr; List.iter (fun tex -> box false tex; Cairo.translate cr tx 0.) texs; Cairo.restore cr; Cairo.save cr; Cairo.translate cr 0. ty; List.iter (fun tex -> box true tex; Cairo.translate cr tx 0.) texs; Cairo.restore cr in draw_all 100. 100.; Cairo.translate cr 0. 200.; Cairo.scale cr 2. 2.; draw_all 60. 50. let _ = create_pdf 20. 29.7 draw "testspline_lib.pdf" mlpost-0.8.1/backend/gentex.ml0000644000443600002640000000671211365367177015442 0ustar kanigdemons(**************************************************************************) (* *) (* 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 genfile_name = "gentex" let default_prelude = "\\documentclass{article}\n" let _ = Random.self_init () let debug = false let tempdir = Metapost_tool.tempdir type t = {tex : Dev_save.t; trans : Matrix.t} module Saved_device = Dviinterp.Interp(Dev_save.Dev_save) let set_verbosity b = Saved_device.set_verbosity b let create prelude = function | [] -> [] | texs -> let format fmt = Printf.fprintf fmt "%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} %a \\end{document}" (if prelude = "" then default_prelude else prelude) (fun fmt -> List.iter (Printf.fprintf fmt "\\mpxshipout %s\\stopmpxshipout")) texs in let todo _ pwd = let latex = genfile_name^".tex" in let file = open_out latex in Printf.fprintf file "%t" format; close_out file; let exit_status = Sys.command (sprintf "%s -halt-on-error %s > \ gentex_dev_null.log" com_latex latex) in if exit_status <> 0 then failwith (sprintf "Error with : %s : \ %s %s log in gentex.log" pwd com_latex latex); let dvi = genfile_name^".dvi" in let saved = Saved_device.load_file true dvi in List.map (fun x -> {tex = x;trans= Matrix.identity}) (Dev_save.separe_pages saved) in tempdir genfile_name "" todo let point_of_cm cm = (0.3937 *. 72.) *. cm let get_dimen_cm x = Dev_save.get_dimen_first_page x.tex 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 = Dev_save.get_bases_first_page x.tex let get_bases_pt x = List.map point_of_cm (get_bases_cm x) let bounding_box x = let (xmin,ymin,xmax,ymax) = get_dimen_pt x in if 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 mlpost-0.8.1/backend/draw.mli0000644000443600002640000000322511365367177015252 0ustar kanigdemons(**************************************************************************) (* *) (* 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.1/backend/myocamlbuild.ml0000644000443600002640000001077111365367177016631 0ustar kanigdemons(**************************************************************************) (* *) (* 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.1/backend/dvicairo.ml0000644000443600002640000001633111365367177015746 0ustar kanigdemons(**************************************************************************) (* *) (* 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 type multi_page_pic = {pic :Cairo.t; new_page : unit -> unit; x_origin : float; y_origin : float } 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 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 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 set_source_color pic = function | RGB(r,g,b) -> if !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 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.arg.x_origin and y1 = point_of_cm y1 +. s.arg.y_origin and w = point_of_cm w and h = point_of_cm h in if !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 try printf "Draw the char %i(%c) of %s in (%f,%f) x%f@." char (Char.chr char) name x y ratio; with _ -> printf "Draw the char %i of %s in (%f,%f) x%f@." char name 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; (* 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) | Some _ | None -> ()); (match Fonts.extend font with | Some a when !info -> printf "extend of %f not used for %s@." a (Fonts.tex_name font) | Some _ | None -> ()); Cairo.show_glyphs s.arg.pic [|{Cairo.index = char; Cairo.glyph_x = x; Cairo.glyph_y = y}|]; Cairo.stroke s.arg.pic; Cairo.restore s.arg.pic let specials s info xxx x y = if !debug || !specials 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 mlpost-0.8.1/backend/testdvi.ml0000644000443600002640000000257011365367177015630 0ustar kanigdemons(**************************************************************************) (* *) (* 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 let _ = match Array.length Sys.argv with | 1 -> printf "Usage : dvi ...\n" | n -> for i = 1 to n-1 do let s = Sys.argv.(i) in Print.print_doc s std_formatter (read_file s) done mlpost-0.8.1/backend/lookForTeX.ml0000644000443600002640000001703411365367177016203 0ustar kanigdemons(**************************************************************************) (* *) (* 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 mlpost-0.8.1/backend/compute.ml0000644000443600002640000003057311365367177015626 0ustar kanigdemons(**************************************************************************) (* *) (* 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 debug = true 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 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 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 prelude = ref "" let set_prelude = (:=) prelude let set_verbosity b = Gentex.set_verbosity b 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' = function | F f -> (*float_to_metapost*) f | NXPart p -> let p = point p in p.P.x | NYPart p -> let p = point p in p.P.y | NAdd(n1,n2) -> let n1 = num n1 in let n2 = num n2 in n1 +. n2 | NSub(n1,n2) -> let n1 = num n1 in let n2 = num n2 in n1 -. n2 | NMult (n1,n2) -> let n1 = num n1 in let n2 = num n2 in n1*.n2 | NDiv (n1,n2) -> let n1 = num n1 in let n2 = num n2 in if n2 = 0. then failwith "Concrete : division by zero" else n1/.n2 | NMax (n1,n2) -> let n1 = num n1 in let n2 = num n2 in max n1 n2 | NMin (n1,n2) -> let n1 = num n1 in let n2 = num n2 in min n1 n2 | NGMean (n1,n2) -> let n1 = num n1 in let n2 = num n2 in sqrt (n1*.n1+.n2*.n2) | NLength p -> let p = path p in Spline_lib.metapost_length p | NIfnullthenelse (n,n1,n2) -> let n = num n in if n = 0. then num n1 else num n2 and num n = memoize num' "num" num_memoize n 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 dl,p,_ = metapath p in let j = joint dl 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 let f1 = Spline_lib.abscissa_of_metapost p (num f1) in let f2 = Spline_lib.abscissa_of_metapost p (num f2) in Spline_lib.subpath p f1 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 -> (* With lookfortex we never pass this point *) let tex = List.hd (Gentex.create !prelude [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 = match t.Hashcons.node with | TRRotated f -> Matrix.rotation (deg2rad f) | TRScaled f -> Matrix.scale (num f) | TRSlanted f -> Matrix.slanted (num f) | TRXscaled f -> Matrix.xscaled (num f) | TRYscaled f -> Matrix.yscaled (num f) | TRShifted p -> let p = point p in Matrix.translation p | TRZscaled p -> Matrix.zscaled (point p) | TRReflect (p1,p2) -> Matrix.reflect (point p1) (point p2) | TRRotateAround (p,f) -> Matrix.rotate_around (point p) (deg2rad f) | TRMatrix p -> {Ctypes.x0 = num p.Types.x0; Ctypes.y0 = num p.Types.y0; Ctypes.xx = num p.Types.xx; Ctypes.xy = num p.Types.xy; Ctypes.yx = num p.Types.yx; Ctypes.yy = num p.Types.yy} 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 mlpost-0.8.1/backend/_tags0000644000443600002640000000027411365367177014633 0ustar kanigdemons<*dvicairo.*> or : pkg_lablgtk2, pkg_cairo.lablgtk2 <*dvicairo.*> : pkg_cairo : pkg_cairo : pkg_cairo : pkg_cairo <*.cmx> : for-pack(Mlpost) mlpost-0.8.1/backend/picture_lib.mli0000644000443600002640000000505111365367177016615 0ustar kanigdemons(**************************************************************************) (* *) (* 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 = private | 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 * float 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 bounding_box : t -> Point_lib.t * Point_lib.t (* 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 mlpost-0.8.1/backend/testdviinterp.ml0000644000443600002640000000325711365367177017055 0ustar kanigdemons(**************************************************************************) (* *) (* 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 module Dumb_device = struct type t = unit type cooked = unit type arg = unit let new_document _ _ = () let new_page () = () let fill_rect () _ _ _ _ = () let draw_char () _ _ _ _ = () let end_document () = () end module Dumb_interp = Interp(Dumb_device) let _ = Dumb_interp.set_debug true; match Array.length Sys.argv with | 1 -> printf "Usage : dviinterp ...\n" | n -> for i = 1 to n-1 do let s = Sys.argv.(i) in ignore (Dumb_interp.load_file () s) done mlpost-0.8.1/backend/gentex.mli0000644000443600002640000000310211365367177015601 0ustar kanigdemons(**************************************************************************) (* *) (* 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 : Dev_save.t; trans : Matrix.t} val create : string -> string list -> t list 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 (** donne la dimension en centimètre *) mlpost-0.8.1/backend/test_spline.ml0000644000443600002640000003124311365367177016476 0ustar kanigdemons(**************************************************************************) (* *) (* 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 _ = GMain.Main.init () type point = Cairo.point = { x : float ; y : float } type one_spl = { pt : point array; mutable active : int; } type spl = { mutable pm : GDraw.pixmap ; mutable spls : one_spl list; mutable tolerance : float ; mutable line_width : float ; line_cap : Cairo.line_cap ; mutable zoom : float ; mutable xtrans : float ; mutable ytrans : float ; mutable click : bool ; mutable drag_pt : point ; mutable width : int ; mutable height : int ; mutable need_update : bool ; mutable myfun_active : bool ; myfun : point array list -> point list ; } let ribbon = [| 110., 20. ; 310., 300. ; 10. , 310. ; 210., 20. |] let point_dist_min = {x = 100.;y=100.} let nb_feature = 4 let select_feature = ref 0 let inter_depth = Spline_lib.inter_depth let debug = Spline_lib.debug let spline_copy arr = {pt = Array.map (fun (x, y) -> { x = x ; y = y }) arr; active = 0} let exec_on_spls f spls = f (List.map (fun {pt = pt} -> pt) spls) 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 init_spl myfun = let width = 400 in let height = 400 in { pm = new_pixmap width height ; spls = [spline_copy ribbon] ; tolerance = 0.1 ; line_width = 10. ; line_cap = Cairo.LINE_CAP_ROUND ; zoom = 1. ; xtrans = 0. ; ytrans = 0. ; click = false ; drag_pt = { x = 0. ; y = 0. } ; width = width ; height = height ; need_update = true ; myfun_active = true; myfun = myfun; } let draw_control_line cr a b w = Cairo.save cr ; begin Cairo.set_source_rgb cr 0. 0. 1. ; Cairo.set_line_width cr w ; Cairo.move_to cr a.x a.y ; Cairo.line_to cr b.x b.y ; Cairo.stroke cr end ; Cairo.restore cr let two_pi = 8. *. atan 1. let draw_spline cr spl one_spl = let drag_pt = { x = spl.drag_pt.x ; y = spl.drag_pt.y } in let drag_pt = Cairo.device_to_user cr drag_pt in Cairo.save cr ; begin Cairo.move_to cr one_spl.pt.(0).x one_spl.pt.(0).y ; Cairo.curve_to cr one_spl.pt.(1).x one_spl.pt.(1).y one_spl.pt.(2).x one_spl.pt.(2).y one_spl.pt.(3).x one_spl.pt.(3).y ; if spl.click && Cairo.in_stroke cr drag_pt then one_spl.active <- 0xf ; Cairo.stroke cr ; draw_control_line cr one_spl.pt.(0) one_spl.pt.(1) (2. /. spl.zoom) ; draw_control_line cr one_spl.pt.(3) one_spl.pt.(2) (2. /. spl.zoom) ; for i=0 to 3 do Cairo.save cr ; begin Cairo.set_source_rgba cr 1. 0. 0. 0.5 ; Cairo.new_path cr ; Cairo.arc cr one_spl.pt.(i).x one_spl.pt.(i).y (spl.line_width /. 1.25) 0. two_pi ; if spl.click && Cairo.in_fill cr drag_pt then begin one_spl.active <- 1 lsl i ; end ; Cairo.fill cr end ; Cairo.restore cr done end ; Cairo.restore cr let draw_point spl cr col pt = Cairo.save cr ; (match col with |`Green -> Cairo.set_source_rgba cr 0. 1. 0. 0.5 ; |`Yellow -> Cairo.set_source_rgba cr 0. 1. 1. 0.5); Cairo.new_path cr ; Cairo.arc cr pt.x pt.y (spl.line_width /. 1.25) 0. two_pi ; Cairo.fill cr; Cairo.restore cr let paint spl = let cr = Cairo_lablgtk.create spl.pm#pixmap in spl.pm#rectangle ~x:0 ~y:0 ~width:spl.width ~height:spl.height ~filled:true () ; Cairo.set_source_rgb cr 0. 0. 0. ; Cairo.set_line_width cr spl.line_width ; Cairo.set_line_cap cr spl.line_cap ; Cairo.translate cr spl.xtrans spl.ytrans ; Cairo.scale cr spl.zoom spl.zoom ; Cairo.set_tolerance cr spl.tolerance ; (try List.iter (draw_spline cr spl) spl.spls ; spl.need_update <- false with Cairo.Error _ -> prerr_endline "Cairo is unhappy"); if spl.click then spl.click <- false; if spl.myfun_active then List.iter (draw_point spl cr `Green) (exec_on_spls spl.myfun spl.spls); draw_point spl cr `Yellow point_dist_min let trans_horiz_cb dir spl = let delta = float spl.width /. 16. in begin match dir with | `LEFT -> spl.xtrans <- spl.xtrans -. delta | `RIGHT -> spl.xtrans <- spl.xtrans +. delta end ; true let trans_vert_cb dir spl = let delta = float spl.height /. 16. in begin match dir with | `UP -> spl.ytrans <- spl.ytrans -. delta | `DOWN -> spl.ytrans <- spl.ytrans +. delta end ; true let zoom_cb dir spl = begin match dir with | `OUT -> spl.zoom <- spl.zoom /. 1.1 | `IN -> spl.zoom <- spl.zoom *. 1.1 end ; true let smooth_cb dir spl = begin match dir with | `INC -> spl.tolerance <- spl.tolerance *. 10. | `DEC -> spl.tolerance <- spl.tolerance /. 10. end ; true let line_width_cb dir spl = begin match dir with | `W -> spl.line_width <- spl.line_width *. 2. | `N -> spl.line_width <- spl.line_width /. 2. end ; true let gest_spline action spl = begin match action with | `ADD -> spl.spls <- (spline_copy ribbon)::spl.spls | `REMOVE -> spl.spls <- (match spl.spls with [] -> [] | _::l -> l) end; true let pt_f fmt p = Format.fprintf fmt "{@[ %.20g,@ %.20g @]}" p.x p.y let print_spline = fun pt -> Format.printf "@[{ %a,@ %a,@ %a,@ %a }@]@." pt_f pt.(0) pt_f pt.(1) pt_f pt.(2) pt_f pt.(3) let print_one_spl {pt = pt} = print_spline pt let print_spline_cb { spls = spls; myfun = myfun } = List.iter print_one_spl spls; List.iter (Format.printf "@[%a@]@." pt_f) (exec_on_spls myfun spls); Format.printf "depth : %i@." !Spline_lib.inter_depth; false module K = GdkKeysyms let keybindings = [ K._q, ("q", (fun _ -> GMain.quit () ; false), "Exit the program") ; K._Left, ("Left", trans_horiz_cb `LEFT, "Translate left") ; K._Right, ("Right", trans_horiz_cb `RIGHT, "Translate right" ) ; K._Up, ("Up", trans_vert_cb `UP, "Translate up" ) ; K._Down, ("Down", trans_vert_cb `DOWN, "Translate down") ; K._Return, ("Return", print_spline_cb, "Print current spline coordinates on stdout") ; K._plus, ("plus", zoom_cb `IN, "Zoom in") ; K._minus, ("minus", zoom_cb `OUT, "Zoom out") ; K._greater, ("greater", smooth_cb `DEC, "Increase rendering accuracy, (tolerance /= 10)") ; K._less, ("less", smooth_cb `INC, "Decrease rendering accuracy, (tolerance *= 10)") ; K._w, ("w", line_width_cb `W, "Widen line width") ; K._n, ("n", line_width_cb `N, "Narrow line width") ; K._a, ("a", gest_spline `ADD, "Add a spline") ; K._r, ("r", gest_spline `REMOVE, "Remove a spline") ; K._f, ("f", (fun spl -> spl.myfun_active<-not spl.myfun_active;true), "Switch the fun fun") ; K._c, ("c", (fun _ -> select_feature := (!select_feature + 1) mod nb_feature;true), "Change the green points which appear") ; K._d, ("d", (fun _ -> inter_depth := max 0 (!inter_depth-1);true), "Change the depth for the intersection") ; K._D, ("D", (fun _ -> incr(inter_depth);true), "Change the depth for the intersection") ; K._e, ("e", (fun _ -> debug:= not !debug;!debug), "Print debug information") ; ] let refresh da spl = spl.need_update <- true ; GtkBase.Widget.queue_draw da#as_widget let grow_pixmap spl = spl.pm <- new_pixmap spl.width spl.height ; spl.need_update <- true (* no need to queue a redraw here, an expose event should follow the configure, right ? *) let config_cb spl ev = let w = GdkEvent.Configure.width ev in let h = GdkEvent.Configure.height ev in let has_grown = w > spl.width || h > spl.height in spl.width <- w ; spl.height <- h ; if has_grown then grow_pixmap spl ; true let expose da spl 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 spl.pm#pixmap let expose_cb da spl ev = let area = GdkEvent.Expose.area ev in let module GR = Gdk.Rectangle in if spl.need_update then paint spl ; expose da spl (GR.x area) (GR.y area) (GR.width area) (GR.height area) ; true let key_press_cb da spl ev = try let (_, cb, _) = List.assoc (GdkEvent.Key.keyval ev) keybindings in let need_refresh = cb spl in if need_refresh then refresh da spl ; true with Not_found -> false let button_ev da spl ev = match GdkEvent.get_type ev with | `BUTTON_PRESS -> spl.click <- true ; spl.drag_pt <- { x = GdkEvent.Button.x ev ; y = GdkEvent.Button.y ev } ; true | `BUTTON_RELEASE -> spl.click <- false ; List.iter (fun one_spl -> one_spl.active <- 0) spl.spls; true | _ -> false let motion_notify_cb da spl ev = let x = GdkEvent.Motion.x ev in let y = GdkEvent.Motion.y ev in List.iter (fun one_spl -> for i=0 to 3 do if (1 lsl i) land one_spl.active != 0 then begin let x = one_spl.pt.(i).x +. (x -. spl.drag_pt.x) /. spl.zoom in let y = one_spl.pt.(i).y +. (y -. spl.drag_pt.y) /. spl.zoom in one_spl.pt.(i) <- { x = x ; y = y } end done ;) spl.spls; spl.drag_pt <- { x = x ; y = y } ; refresh da spl ; true let init spl packing = let da = GMisc.drawing_area ~width:spl.width ~height:spl.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 spl)) ; ignore (da#event#connect#configure (config_cb spl)); ignore (da#event#connect#button_press (button_ev da spl)) ; ignore (da#event#connect#button_release (button_ev da spl)) ; ignore (da#event#connect#motion_notify (motion_notify_cb da spl)) ; ignore (da#event#connect#key_press (key_press_cb da spl)) let show_help kb = Format.printf "@[" ; List.iter (fun (_, (key, _, descr)) -> Format.printf "%10s: %s@ " key descr) kb ; Format.printf "@." let rec one_to_one f a = function | [] -> a | e::l -> one_to_one f (List.fold_left (f e) a l) l let rec keep f a = function | [] -> a | b::l -> if f a b then keep f a l else keep f b l (* Prend une liste de splines en argument et renvoit une liste de points à afficher *) (*[start;start_control;end_control;end]*) let myfun (spls:point array list) : point list = let map f = List.map (function | [|a;b;c;d|] -> let s = Spline_lib.create a b c d in f s | _ -> assert false) in match !select_feature with | 0 -> one_to_one (fun a lpt b -> (List.map (fun (tp,_) -> Spline_lib.abscissa_to_point a tp) (Spline_lib.intersection a b))@lpt) [] (map (fun x -> x) spls) | 1 -> map (fun s -> Spline_lib.abscissa_to_point s (Spline_lib.dist_min_point s point_dist_min)) spls | 2 -> one_to_one (fun a lpt b -> ((fun (tp,_) -> Spline_lib.abscissa_to_point a tp) (Spline_lib.dist_min_path a b))::lpt) [] (map (fun x -> x) spls) | 3 -> one_to_one (fun a lpt b -> try ((fun (tp,_) -> Spline_lib.abscissa_to_point a tp) (Spline_lib.one_intersection a b))::lpt with Not_found -> lpt) [] (map (fun x -> x) spls) | _ -> assert false let main = let w = GWindow.window ~title:"Cairo spline demo" ~allow_grow:true ~allow_shrink:true () in ignore (w#connect#destroy GMain.quit) ; init (init_spl myfun) w#add ; show_help keybindings ; w#show () ; GMain.main () mlpost-0.8.1/backend/draw.ml0000644000443600002640000001231011365367177015074 0ustar kanigdemons(**************************************************************************) (* *) (* 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 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.}; 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,width) -> Cairo.save cr; 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 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.1/backend/testtfm.ml0000644000443600002640000000257011365367177015634 0ustar kanigdemons(**************************************************************************) (* *) (* 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 Tfm let _ = match Array.length Sys.argv with | 1 -> printf "Usage : tfm ...\n" | n -> for i = 1 to n-1 do let s = Sys.argv.(i) in Print.print_tfm s std_formatter (read_file s) done mlpost-0.8.1/backend/picture_lib.ml0000644000443600002640000001534311365367177016451 0ustar kanigdemons(**************************************************************************) (* *) (* 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 * float 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 height,width = begin match spec with | `Exact (h,w) -> (h,w) | ((`None as spec)| (`Height _ as spec)| (`Width _ as spec) |(`Inside _ as spec)) -> let fh,fw = externalimage_dimension filename in match spec with | `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 {fcl = ExternalImage (filename,height,width); 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 on_top t1 t2 = {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 | _ -> [] 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 mlpost-0.8.1/backend/standardenc.ml0000644000443600002640000001456611365367177016444 0ustar kanigdemons(**************************************************************************) (* *) (* 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 standardencoding = [| ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; "space"; "exclam"; "quotedbl"; "numbersign"; "dollar"; "percent"; "ampersand"; "quoteright"; "parenleft"; "parenright"; "asterisk"; "plus"; "comma"; "hyphen"; "period"; "slash"; "zero"; "one"; "two"; "three"; "four"; "five"; "six"; "seven"; "eight"; "nine"; "colon"; "semicolon"; "less"; "equal"; "greater"; "question"; "at"; "A"; "B"; "C"; "D"; "E"; "F"; "G"; "H"; "I"; "J"; "K"; "L"; "M"; "N"; "O"; "P"; "Q"; "R"; "S"; "T"; "U"; "V"; "W"; "X"; "Y"; "Z"; "bracketleft"; "backslash"; "bracketright"; "asciicircum"; "underscore"; "quoteleft"; "a"; "b"; "c"; "d"; "e"; "f"; "g"; "h"; "i"; "j"; "k"; "l"; "m"; "n"; "o"; "p"; "q"; "r"; "s"; "t"; "u"; "v"; "w"; "x"; "y"; "z"; "braceleft"; "bar"; "braceright"; "asciitilde"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; "exclamdown"; "cent"; "sterling"; "fraction"; "yen"; "florin"; "section"; "currency"; "quotesingle"; "quotedblleft"; "guillemotleft"; "guilsinglleft"; "guilsinglright"; "fi"; "fl"; ".notdef"; "endash"; "dagger"; "daggerdbl"; "periodcentered"; ".notdef"; "paragraph"; "bullet"; "quotesinglbase"; "quotedblbase"; "quotedblright"; "guillemotright"; "ellipsis"; "perthousand"; ".notdef"; "questiondown"; ".notdef"; "grave"; "acute"; "circumflex"; "tilde"; "macron"; "breve"; "dotaccent"; "dieresis"; ".notdef"; "ring"; "cedilla"; ".notdef"; "hungarumlaut"; "ogonek"; "caron"; "emdash"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; "AE"; ".notdef"; "ordfeminine"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; "Lslash"; "Oslash"; "OE"; "ordmasculine"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; "ae"; ".notdef"; ".notdef"; ".notdef"; "dotlessi"; ".notdef"; ".notdef"; "lslash"; "oslash"; "oe"; "germandbls"; ".notdef"; ".notdef"; ".notdef"; ".notdef" |] let isoencoding = [| ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; "space"; "exclam"; "quotedbl"; "numbersign"; "dollar"; "percent"; "ampersand"; "quotesingle"; "parenleft"; "parenright"; "asterisk"; "plus"; "comma"; "hyphen"; "period"; "slash"; "zero"; "one"; "two"; "three"; "four"; "five"; "six"; "seven"; "eight"; "nine"; "colon"; "semicolon"; "less"; "equal"; "greater"; "question"; "at"; "A"; "B"; "C"; "D"; "E"; "F"; "G"; "H"; "I"; "J"; "K"; "L"; "M"; "N"; "O"; "P"; "Q"; "R"; "S"; "T"; "U"; "V"; "W"; "X"; "Y"; "Z"; "bracketleft"; "backslash"; "bracketright"; "asciicircum"; "underscore"; "grave"; "a"; "b"; "c"; "d"; "e"; "f"; "g"; "h"; "i"; "j"; "k"; "l"; "m"; "n"; "o"; "p"; "q"; "r"; "s"; "t"; "u"; "v"; "w"; "x"; "y"; "z"; "braceleft"; "bar"; "braceright"; "asciitilde"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; ".notdef"; "dotlessi"; "quoteleft"; "quoteright"; "circumflex"; "tilde"; "macron"; "breve"; "dotaccent"; "dieresis"; ".notdef"; "ring"; "cedilla"; ".notdef"; "hungarumlaut"; "ogonek"; "caron"; "space"; "exclamdown"; "cent"; "sterling"; "currency"; "yen"; "brokenbar"; "section"; "dieresis"; "copyright"; "ordfeminine"; "guillemotleft"; "logicalnot"; "hyphen"; "registered"; "macron"; "degree"; "plusminus"; "twosuperior"; "threesuperior"; "acute"; "mu"; "paragraph"; "periodcentered"; "cedilla"; "onesuperior"; "ordmasculine"; "guillemotright"; "onequarter"; "onehalf"; "threequarters"; "questiondown"; "Agrave"; "Aacute"; "Acircumflex"; "Atilde"; "Adieresis"; "Aring"; "AE"; "Ccedilla"; "Egrave"; "Eacute"; "Ecircumflex"; "Edieresis"; "Igrave"; "Iacute"; "Icircumflex"; "Idieresis"; "Eth"; "Ntilde"; "Ograve"; "Oacute"; "Ocircumflex"; "Otilde"; "Odieresis"; "multiply"; "Oslash"; "Ugrave"; "Uacute"; "Ucircumflex"; "Udieresis"; "Yacute"; "Thorn"; "germandbls"; "agrave"; "aacute"; "acircumflex"; "atilde"; "adieresis"; "aring"; "ae"; "ccedilla"; "egrave"; "eacute"; "ecircumflex"; "edieresis"; "igrave"; "iacute"; "icircumflex"; "idieresis"; "eth"; "ntilde"; "ograve"; "oacute"; "ocircumflex"; "otilde"; "odieresis"; "divide"; "oslash"; "ugrave"; "uacute"; "ucircumflex"; "udieresis"; "yacute"; "thorn"; "ydieresis" |] mlpost-0.8.1/customdoc/0000755000443600002640000000000011365367167014220 5ustar kanigdemonsmlpost-0.8.1/customdoc/all.template0000644000443600002640000000030411365367177016523 0ustar kanigdemons\documentclass{article} \usepackage{graphicx} \pagestyle{empty} \begin{document} \includegraphics[scale=3]{all.1} \end{document} %%% Local Variables: %%% mode: latex %%% TeX-master: t %%% End: mlpost-0.8.1/customdoc/_tags0000644000443600002640000000012511365367177015237 0ustar kanigdemons : use_ocamldoc : use_unix, pkg_cairo, pkg_bitstring, use_bigarraymlpost-0.8.1/customdoc/img_doc.ml0000644000443600002640000001014111365367177016151 0ustar kanigdemonsopen 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.1/customdoc/Makefile0000644000443600002640000000006711365367177015664 0ustar kanigdemonsimg.cmo: img.ml ocamlc -I +ocamldoc -c -dtypes img.ml mlpost-0.8.1/customdoc/img.ml0000644000443600002640000000155111365367177015331 0ustar kanigdemonsclass 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 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.1/generate.ml0000644000443600002640000000540611365367177014352 0ustar kanigdemons(**************************************************************************) (* *) (* 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 let minipage fmt coef i tmpl sep suf = fprintf fmt "@[\\begin{minipage}[tb]{%f\\textwidth}@\n" coef; fprintf fmt "@[\\begin{center}@\n"; fprintf fmt "\\includegraphics[width=\\textwidth,height=\\textwidth,keepaspectratio]{%s%s%i%s}" tmpl sep i suf; fprintf fmt "@]@\n\\end{center}@\n"; fprintf fmt "@]@\n\\end{minipage}@\n" let generate_tex ?(pdf=false) tf tmpl1 tmpl2 l = let suf = if pdf then ".mps" else "" in let sep = if pdf then "-" else "." in Misc.write_to_formatted_file tf (fun fmt -> fprintf fmt "\\documentclass[a4paper]{article}@."; fprintf fmt "\\usepackage[]{graphicx}@."; fprintf fmt "@[\\begin{document}@."; List.iter (fun (i,_) -> fprintf fmt "@\n %i" i; minipage fmt 0.5 i tmpl1 sep suf; minipage fmt 0.5 i tmpl2 sep suf; fprintf fmt "@\n \\vspace{3cm}@\n" ) l ; fprintf fmt "@]@\n\\end{document}@.") let generate_tex_cairo tf tmpl1 tmpl2 tmpl3 l = Misc.write_to_formatted_file tf (fun fmt -> fprintf fmt "\\documentclass[a4paper]{article}@."; fprintf fmt "\\usepackage[]{graphicx}@."; fprintf fmt "@[\\begin{document}@."; List.iter (fun (i,_) -> fprintf fmt "@\n %i" i; minipage fmt 0.3 i tmpl1 "-" ".mps"; minipage fmt 0.3 i tmpl2 "-" ".mps"; minipage fmt 0.3 i tmpl3 "-" ".pdf"; fprintf fmt "@\n \\vspace{3cm}@\n" ) l ; fprintf fmt "@]@\n\\end{document}@.") mlpost-0.8.1/box.ml0000644000443600002640000005716011365367177013354 0ustar kanigdemons(**************************************************************************) (* *) (* 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 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 ?(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 name = match name with | None -> fresh_name () | Some s -> Name.Userdef s in { desc = desc; name = name; stroke = stroke; pen = pen; fill = fill; dash = dash; width = w; height = h; ctr = c; contour = s; post_draw = post_draw; pre_draw = pre_draw } let pic ?style ?dx ?dy ?name ?(stroke=None) ?pen ?dash ?fill pic = let c = Picture.ctr pic in mkbox ?style ?dx ?dy ?name ~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 ?stroke ?pen ?dash ?fill b = mkbox ?style ?dx ?dy ?name ?stroke ?pen ?dash ?fill (width b) (height b) (ctr b) (Grp ([|b|], merge_maps [b] )) let path ?style ?dx ?dy ?name ?(stroke=None) ?pen ?dash ?fill p = pic ?style ?dx ?dy ?name ~stroke ?pen ?dash ?fill (Picture.make (Command.draw p)) let empty ?(width=Num.zero) ?(height=Num.zero) ?style ?name ?(stroke=None) ?pen ?dash ?fill () = mkbox ?style ?name ~dx:zero ~dy:zero ~stroke ?pen ?dash ?fill width height Point.origin Emp let empty_from_box ?style ?name ?(stroke=None) ?pen ?dash ?fill box = mkbox ?style ?name ~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 ?(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 ~stroke ?pen ?dash ?fill () | [b] -> box ?style ~dx ~dy ?name ~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 ~stroke ?pen ?dash ?fill w h c (Grp (Array.of_list bl, merge_maps bl)) let group_array ?name ?stroke ?fill ?dx ?dy ba = group ?name ?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 -> ?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 ?(stroke=None) ?pen ?dash ?fill s = pic ?style ?dx ?dy ?name ~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 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 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 chgp pos1 y1 pos2 y2 b = let pos1 = mycorner pos1 b in let pos2 = mycorner pos2 b in let conv x = let a = (y1 -/ y2) // (pos1 -/ pos2) in let b = ((y2 */ pos1) -/ (y1 */ pos2)) // (pos1 -/ pos2) in a */ x +/ b in let h = conv b.height in let ctr = chgp conv b.ctr in { b with height = h; ctr = ctr } let set_height2 pos1 y1 pos2 y2 b = set_gen2 cornerv (fun conv p -> Point.pt (xpart p, conv (ypart p))) pos1 y1 pos2 y2 b let set_width2 pos1 y1 pos2 y2 b = set_gen2 cornerh (fun conv p -> Point.pt (conv (xpart p),ypart p)) 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 ?stroke ?pen ?dash ?fill l = group ?style ?dx ?dy ?name ?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 ?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 ~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 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 a b = let r,l = outd, ind in let p = P.pathk ?style [P.knotp ?r (ctr a); P.knotp ?l b] in P.cut_before (bpath a) p let cpath_right ?style ?outd ?ind a b = let r,l = outd, ind in let p = P.pathk ?style [P.knotp ?r a; P.knotp ?l (ctr b)] in 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.1/myocamlbuild.ml.in0000644000443600002640000001576211365367177015654 0ustar kanigdemons(**************************************************************************) (* *) (* 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. *) (* *) (**************************************************************************) # 18 "myocamlbuild.ml.in" open Ocamlbuild_plugin open Command let tagcairo = ref false let tagconcrete = ref false let packages_cairo = ["cairo","@CAIROLIB@","cairo"; ] let packages () = let acc = [ "lablgtk2","@LABLGTK2LIB@","lablgtk"; "lablgnomecanvas","@LABLGTK2LIB@","lablgnomecanvas"; ] in if !tagconcrete then ("bitstring","@BITSTRINGLIB@","bitstring") :: acc else acc let gen_def_string () = let l = [] in let l = if !tagconcrete then "-D CONCRETE" :: l else l in let l = if !tagcairo then "-D CAIRO"::l else l in l let string_flatten l = List.fold_left (fun acc s -> acc ^ " " ^ s) "" l let syntaxes () = let bitstring_entry = let cmd = "@CAMLP4O@ -I @BITSTRINGLIB@ bitstring.cma \ bitstring_persistent.cma pa_bitstring.cmo" in "bitstring", cmd, cmd in let s = string_flatten (gen_def_string ()) in let compile_cmd = "@CAMLP4O@ Camlp4MacroParser.cmo " ^ s in let doc_cmd = "./myocamlmacroparser.native " ^ s in let mymacroparser_entry = "mymacroparser",compile_cmd, doc_cmd in let macro_entry = "macro", compile_cmd, compile_cmd in [ bitstring_entry ; mymacroparser_entry ; macro_entry ] let img_doc_prod = ["circle";"rect";"ellipse";"round_rect"; "patatoid";"tex";"ctr";"north";"south"; "west";"east";"north_west";"south_west"; "north_east";"south_east";"width";"height"; "shift";"center";"halign"; "hplace"; "hbox"; ] let _ = dispatch begin function | Before_options -> Options.include_dirs := "concrete"::"dvi"::"backend"::"gui"::!Options.include_dirs; Options.exclude_dirs := "presentations"::"papers"::"examples":: "contrib/dot/_build"::"contrib/lablgtk/_build":: "test"::!Options.exclude_dirs; Options.ocamldoc := S[A"@OCAMLDOC@"] | Before_rules -> tagcairo := Ocamlbuild_pack.Configuration.has_tag "cairo_yes"; tagconcrete := Ocamlbuild_pack.Configuration.has_tag "concrete_yes"; let yesnofile_rule file yesno ext = rule (file^" generation for "^yesno) ~deps:[file^yesno^ext] ~prod:(file^ext) (fun _ _ -> cp (file^yesno^ext) (file^ext)) in if !tagcairo then begin yesnofile_rule "mlpost" "_cairo" ".mlpack"; end else begin if !tagconcrete then begin yesnofile_rule "mlpost" "_concrete" ".mlpack"; end else begin yesnofile_rule "mlpost" "_no" ".mlpack"; end end; yesnofile_rule "mlpost" "_@LABLGTK2@lablgtk" ".odocl"; let copy file1 file2 = rule (" copy from "^file1^"to "^file2) ~deps:[file1] ~prod:(file2) (fun _ _ -> cp file1 file2) in copy "contrib/dot/mlpost_dot.mli" "mlpost_dot.mli"; copy "contrib/lablgtk/mlpost_lablgtk.mli" "mlpost_lablgtk.mli"; (**doc *) rule "generation of the documentation" ~prod:"doc/index.html" ~deps:["mlpost.docdir/html.stamp";"img/stamp"] (fun _ _ -> Cmd(Sh "rm -rf doc && cp -r mlpost.docdir doc && cp -r img doc")); flag ["ocaml"; "compile"; "use_ocamldoc"] & S[A"-I"; A "+ocamldoc"]; dep ["ocaml";"doc"] ["customdoc/img.cmo"]; dep ["ocaml"; "syntax_mymacroparser"] ["myocamlmacroparser.native"]; flag ["ocaml";"doc"] & S([A"-hide" ; A "Mlpost"; A"-g"; A "customdoc/img.cmo"] @ (if "@LABLGTK2@" = "yes" then [A"-I"; A"@LABLGTK2LIB@"] else [])); rule "generation of the images for the documentation" ~prod:"img/image.png" ~stamp:"img/stamp" ~deps:(List.map (fun x -> "img/"^x^".png") img_doc_prod) (fun _ _ -> Nop); (** For img *) rule "produce image in img from img_doc.ml" ~prods: (List.map (fun x -> "img/"^x^".1") img_doc_prod) ~dep: "customdoc/img_doc.byte" begin fun env _ -> Cmd(Sh "mkdir -p img/ && cd img/ && ../customdoc/img_doc.byte \ >> /dev/null && cd ..") end; (** conversion of images *) rule ".1 -> .dvi" ~prod: "%.dvi" ~deps: ["%.1";"customdoc/all.template"] begin fun env _ -> let base = env "%" in let dirname = Pathname.dirname base in let basename = Pathname.basename base in let sed = Sh(Printf.sprintf "sed -e 's/all/%s/' customdoc/all.template > %s.tex" basename base) in let latex = S[ A "cd" ; P dirname; Sh " && "; A "latex"; A "-interaction"; A "nonstopmode"; A "-file-line-error"; A "-halt-on-error"; A basename; Sh "> /dev/null"; (* DELETE THIS IF YOU WANT TO DEBUG *) ] in Seq[Cmd sed; Cmd latex] end; rule ".dvi -> .ps" ~prod: "%.ps" ~dep: "%.dvi" (fun env _ -> let base = env "%.dvi" in let dirname = Pathname.dirname base in let basename = Pathname.basename base in Cmd(S[A "cd" ; P dirname; Sh " && "; A "dvips"; A "-q"; A "-E"; A basename; A "-o"])); rule ".ps -> png" ~prod: "%.png" ~dep: "%.ps" (fun env _ -> Cmd(S[A "convert"; A(env "%.ps"); A(env "%.png")])); | After_rules -> if !tagcairo then ocaml_lib ~extern:true ~tag_name:("use_cairo_bigarray") "bigarray"; List.iter (fun (pkg,dir,file) -> ocaml_lib ~extern:true ~tag_name:("pkg_"^pkg) ~dir file; flag ["ocaml"; "pack"; "pkg_"^pkg] & S[A"-I"; P dir]; flag ["ocaml"; "doc"; "pkg_"^pkg ] & S[A"-I"; P dir]) (let p = packages () in if !tagcairo then packages_cairo@p else p); List.iter (fun (syntax,pp, doc) -> 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 doc];) (syntaxes ()); | _ -> () end mlpost-0.8.1/plot.ml0000644000443600002640000001571411365367177013541 0ustar kanigdemons(**************************************************************************) (* *) (* 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 Command open Helpers open Path open Num open Num.Infix type skeleton = { width : int; height : int; stepx : Num.t; stepy : Num.t; } let mk_skeleton width height stepx stepy = {width = width; height = height; stepx = stepx; stepy = stepy} type labels = int -> Num.t -> Picture.t option type ticks = (Num.t * Pen.t) option let get_style = function | None -> fun i -> Dash.evenly, Pen.default | Some f -> f let off_pattern = fun i -> Dash.pattern [Dash.on (bp 5.)] let defpen = fun i -> Pen.default let get_borders sx sy h w = zero, sx */ (num_of_int w), sy */ (num_of_int h), zero let draw_grid ?(hdash=off_pattern) ?(vdash=off_pattern) ?(hpen=defpen) ?(vpen=defpen) ?color {width=w; height=h; stepx=sx; stepy=sy} = let maxl, maxr, maxu, maxd = get_borders sx sy h w in let drawline dashed pen p = Command.draw ~pen ~dashed ?color p in let horizontal i = let y = num_of_int i */ sy in let pi = pathn [maxl, y; maxr, y] in drawline (hdash i) (hpen i) pi in let vertical i = let x = num_of_int i */ sx in let pi = pathn [x, maxd; x, maxu] in drawline (vdash i) (vpen i) pi in seq (Misc.fold_from_to (fun acc i -> (horizontal i) :: acc) (Misc.fold_from_to (fun acc i -> (vertical i) :: acc) [] 0 w) 0 h) (* This is a hack, we need the maximal size a label can take *) let label_scale stepx = let max_width = Picture.width ( Picture.tex "$55$") in ( 4. /. 5.) *./ stepx // max_width (* The default label function, it is quite generic as the labels are resized * when they do not fit into a cell *) let deflabel x w = Some (Picture.transform [Transform.scaled (label_scale w)] (Picture.tex (Printf.sprintf "$%d$" x))) let defticks = Some ((bp 0.25), Pen.default) let get_corners maxu maxr = (bp 0., maxu), (maxr, maxu), (bp 0., bp 0.), (maxr, bp 0.) let draw_axes ?(hpen=Pen.default) ?(vpen=Pen.default) ?(hlabel= deflabel) ?(vlabel=deflabel) ?(ticks=defticks) ?(closed=false) ?hcaption ?vcaption {width=w; height=h; stepx=sx; stepy=sy} = let maxl, maxr, maxu, maxd = get_borders sx sy h w in let ul, ur, ll, lr = get_corners maxu maxr in let hcaptcmd = match hcaption with | None -> Command.nop | Some labl -> let hlabels_height = match (hlabel w sx) with | None -> Num.zero | Some pic -> Picture.height pic in let h_caption_height = Picture.height labl in Command.label ~pos:`Southwest labl (Point.pt (num_of_int w */ sx, Num.zero -/ hlabels_height -/ (bp 0.5) */ h_caption_height )) in let vcaptcmd = match vcaption with | None -> Command.nop | Some labl -> let rot_labl = (Picture.transform [Transform.rotated 90.] labl) in let vlabels_width = match (vlabel h sy) with | None -> Num.zero | Some pic -> Picture.width pic in let v_caption_width = Picture.width rot_labl in Command.label ~pos:`Southwest rot_labl (Point.pt ( Num.zero -/ vlabels_width -/ (bp 0.5) */ v_caption_width, num_of_int h */ sy)) in let labelcmd pos p i f = match f i sx with | None -> Command.nop | Some x -> Command.label ~pos x p in let ticks_cmd pathf = match ticks with | None -> Command.nop | Some (f,pen) -> Command.draw ~pen (pathf f) in let horizontal i = let x = num_of_int i */ sx in seq [ labelcmd `South (Point.pt (x,maxd)) i hlabel; ticks_cmd (fun f -> pathn [x,maxd; x, maxd +/ (sy */ f)]); if closed then ticks_cmd (fun f -> pathn [x,maxu; x, maxu -/ sy */f]) else Command.nop ] in let vertical i = let y = num_of_int i */ sy in seq [labelcmd `Left (Point.pt (maxl, y)) i vlabel; ticks_cmd (fun f -> pathn [maxl,y; maxl +/ sx */ f,y]); if closed then ticks_cmd (fun f -> pathn [maxr,y; maxr -/ sy */ f, y]) else Command.nop ] in seq [Command.draw ~pen:hpen (pathn [ll; lr]); Command.draw ~pen:vpen (pathn [ll; ul]); if closed then seq [Command.draw ~pen:hpen (pathn [ul; ur]); Command.draw ~pen:vpen (pathn [lr; ur])] else Command.nop; hcaptcmd; vcaptcmd; seq (Misc.fold_from_to (fun acc i -> (horizontal i) :: acc) (Misc.fold_from_to (fun acc i -> (vertical i) :: acc) [] 0 h) 0 w) ] let draw_simple_axes ?hpen ?vpen hcaption vcaption sk = draw_axes ?hpen ?vpen ~hlabel:(fun _ _ -> None) ~vlabel:(fun _ _ -> None) ~ticks:None ~hcaption:(Picture.tex hcaption) ~vcaption:(Picture.rotate (-90.) (Picture.tex vcaption)) sk type drawing = | Stepwise | Normal let draw_func ?(pen) ?(drawing=Normal) ?style ?dashed ?color ?label ?(from_x=0) ?to_x f {width=w; height=h; stepx=sx; stepy=sy} = let to_x = match to_x with None -> w | Some x -> x in let maxl, maxr, maxu, maxd = get_borders sx sy h w in let ul, ur, ll, lr = get_corners maxu maxr in let box = pathn ~style:jLine ~cycle:jLine [ul;ll;lr;ur] in let normal acc i = let x, y = (num_of_int i) */ sx, (Num.bp (f i)) */ sy in (x,y)::acc in let stepwise (acc,x,y) i = let nx, ny = (num_of_int i) */ sx, (Num.bp (f i)) */ sy in (nx,ny) :: (nx,y) :: acc, nx, ny in let graph = match drawing with | Normal -> Misc.fold_from_to normal [] from_x to_x | Stepwise -> let p, _,_ = Misc.fold_from_to stepwise ([],Num.bp 0.,Num.bp 0.) from_x to_x in p in let pic = Picture.clip (Picture.make (Command.draw ?pen ?dashed ?color (pathn ?style graph))) box in match label with | None -> draw_pic pic | Some (lab, pos, i) -> let pt = Point.pt (num_of_int i */ sx, (Num.bp (f i)) */ sy) in seq [Command.label ~pos lab pt; draw_pic pic] mlpost-0.8.1/shapes.ml0000644000443600002640000001270511365367177014043 0ustar kanigdemons(**************************************************************************) (* *) (* 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 Command open Num open Point open Path open Num.Infix open Types let pi = Num.pi let kappa = mkF (4. *. (sqrt 2. -. 1.) /. 3.) let mkappa = mkF (1. -. (4. *. (sqrt 2. -. 1.) /. 3.)) type t = Path.t (** Rectangles *) let round_rect width height rx ry = let hw,hh = width/./ 2.,height/./ 2. in let rx = maxn zero (minn rx hw) in let ry = maxn zero (minn ry hh) in (* let ul, ur, br, bl = *) (* pt (-.hw, hh), pt (hw, hh), *) (* pt (hw, -.hh), pt (-.hw, -.hh) in *) let ul1, ul2 = pt (neg hw, hh-/(mkappa*/ry)), pt (mkappa*/rx-/hw, hh) in let ur1, ur2 = pt (hw-/mkappa*/rx, hh), pt (hw, hh-/mkappa*/ry) in let br1, br2 = pt (hw, mkappa*/ry-/hh), pt (hw-/mkappa*/rx, neg hh) in let bl1, bl2 = pt (mkappa*/rx-/hw, neg hh), pt (neg hw, mkappa*/ry-/hh) in let knots = knotlist [(noDir, pt (rx-/hw, hh), mkVec right); (noDir, pt (hw-/rx, hh), mkVec right); (noDir, pt (hw, hh-/ry), mkVec down); (noDir, pt (hw, ry-/hh), mkVec down); (noDir, pt (hw-/rx, neg hh), mkVec left); (noDir, pt (rx-/hw, neg hh), mkVec left); (noDir, pt (neg hw, ry-/hh), mkVec up); (noDir, pt (neg hw, hh-/ry), mkVec up)] in let joints = [jLine; mkJControls ur1 ur2; jLine; mkJControls br1 br2; jLine; mkJControls bl1 bl2; jLine] in cycle ~dir:(mkVec right) ~style:(mkJControls ul1 ul2) (jointpathk knots joints) (** Ellipses and Arcs *) let ellipse rx ry = let m theta = pt (rx */ (mkF (cos theta)), ry */ (mkF (sin theta))) in let knots = knotlist [(noDir, m 0., mkVec up); (noDir, m (pi /. 2.), mkVec left); (noDir, m pi, mkVec down); (noDir, m (-. pi /. 2.), mkVec right)] in let r1, r2 = pt (rx, neg (ry*/kappa)), pt (rx, ry*/kappa) in let t1, t2 = pt (rx*/kappa , ry), pt (neg (rx*/kappa), ry) in let l1, l2 = pt (neg rx, ry*/kappa), pt (neg rx, neg (ry*/kappa)) in let b1, b2 = pt (neg (rx*/kappa), neg ry), pt (rx*/kappa, neg ry) in let joints = [mkJControls r2 t1; mkJControls t2 l1; mkJControls l2 b1] in cycle ~dir:(mkVec up) ~style:(mkJControls b2 r1) (jointpathk knots joints) let round_box width height = let w = width /./ 2. and h = height /./ 2. in let mw = neg w and mh = neg h in let dx = h /./ 5. and dy = h /./ 5. in let style = jCurveNoInflex in Path.pathn ~cycle:style ~style [ mw -/ dx, zero; zero, mh -/ dy; w +/ dx, zero; zero, h +/ dy;] (* let arc_ellipse_path ?(close=false) rx ry theta1 theta2 = let curvabs theta = (2. *. theta) /. pi in let path = subpath (curvabs theta1) (curvabs theta2) (full_ellipse_path rx ry) in if close then cycle ~style:JLine (concat ~style:JLine path (NoDir,origin,NoDir)) else path *) let rectangle width height = let w = width /./ 2. in let h = height /./ 2. in let mw = neg w in let mh = neg h in Path.pathn ~cycle:jLine ~style:jLine [ w, mh; w, h; mw, h; mw, mh] let patatoid width height = let wmin,wmax = -0.5 *./ width, 0.5 *./ width in let hmin,hmax = -0.5 *./ height, 0.5 *./ height in let ll = pt (wmin,hmin) in let lr = pt (wmax,hmin) in let ur = pt (wmax,hmax) in let ul = pt (wmin, hmax) in let a = segment (Random.float 1.) ll lr in let b = segment (Random.float 1.) lr ur in let c = segment (Random.float 1.) ur ul in let d = segment (Random.float 1.) ul ll in pathp ~cycle:jCurve [a;b;c;d] let patatoid2 width height = let wmin,wmax = -0.5 *./ width, 0.5 *./ width in let hmin,hmax = -0.5 *./ height, 0.5 *./ height in let ll = pt (wmin,hmin) in let lr = pt (wmax,hmin) in let ur = pt (wmax,hmax) in let ul = pt (wmin, hmax) in let f cl cr x y p = let d = pt (bp x, bp y) in let r = Point.rotate (Random.float 60. -. 30.) d in let l = Point.sub Point.origin r in let r = Point.scale ((Random.float 1. +. 0.5) *./ cl) r in let l = Point.scale ((Random.float 1. +. 0.5) *./ cr) l in (Point.shift p l, Point.shift p r) in let c = 0.25 in let ch = c *./ width in let cv = c *./ height in let l1, r1 = f ch cv 1. 1. ul in let l2, r2 = f cv ch 1. (-1.) ur in let l3, r3 = f ch cv (-1.) (-1.) lr in let l4, r4 = f cv ch (-1.) 1. ll in let path = jointpathp [ ul; ur; lr; ll; ] [ jControls r1 l2; jControls r2 l3; jControls r3 l4; ] in cycle ~style: (jControls r4 l1) path let circle d = Path.scale d Path.fullcircle mlpost-0.8.1/examples/0000755000443600002640000000000011365367167014036 5ustar kanigdemonsmlpost-0.8.1/examples/radar.ml0000644000443600002640000000161711365367177015467 0ustar kanigdemonsopen Mlpost open Command open Num open Color open Box (*parse <> *) (*parse <> <> *) let _ = List.iter (fun (name,fig) -> Metapost.emit name (Picture.scale (Num.bp 3.) fig)) [ "radar1", radar1; "radar2", radar2; ] mlpost-0.8.1/examples/tree.ml0000644000443600002640000001072711365367177015337 0ustar kanigdemonsopen Mlpost open Box open Tree let sprintf = Format.sprintf (*parse <> *) (*parse <> <> <> <> <> <> <> <> < leaf (texint n) | n -> node ~arrow_style:Undirected (texint n) [fib (n-1); fib (n-2)] let tree9 = draw (fib 5) (*parse >> < Node (0, []) | n -> let (Node (_,l) as t) = bin (n-1) in Node (n, t :: l) let rec trans (Node (n,l)) = node ~arrow_style:Undirected (tex (sprintf "${2^{%d}}$" n)) (List.map trans l) let tree10 = draw (trans (bin 4)) (*parse >> < Node (point, []) | n -> let (Node (p,l) as t) = bin (n-1) in Node (p, t :: l) let rec to_tree (Node (b,l)) = node ~arrow_style:Undirected ~valign:`Right b (List.map to_tree l) let tree11 = draw (to_tree (bin 5)) (*parse >> < Tree.node e (List.map to_tree l) let node i e l = Node ([Aft i,tex e],l) let place_not_simple t = let module P = Place(Overlays_Boxlike(Box)) in let bplace t = Tree.to_box (to_tree t) in P.gen_place ~place:bplace t let tree_adv_draw t i = let keep e = try Some (assoq i e) with Not_found -> None in let t = filter_option keep t in let t_arrow = gen_draw_arrows Command.nop ~style:Helpers.draw_simple_arrow ~corner:Box.corner t in (Tree_adv.draw (fun x -> x) t) ++ (fold (++) Command.nop t_arrow) let mytree_placed = let t = node 0 "A" [ node 0 "B" [node 0 "D" [];node 0 "E" []]; node 0 "C" [node 1 "F" [];node 2 "G" []]] in place_not_simple t let tree12 = tree_adv_draw mytree_placed 0 (*parse >> <> <> *) let _ = List.iter (fun (name,fig) -> Metapost.emit name (Picture.scale (Num.bp 3.) fig)) [ "tree1", tree1; "tree2", tree2; "tree3", tree3; "tree4", tree4; "tree5", tree5; "tree6", tree6; "tree7", tree7; "tree8", tree8; "tree9", tree9; "tree10", tree10; "tree11", tree11; "tree12", tree12; "tree13", tree13; "tree14", tree14; ] mlpost-0.8.1/examples/all.template0000644000443600002640000000037011365367177016344 0ustar kanigdemons\documentclass{article} \usepackage{graphicx} \pagestyle{empty} \usepackage[paperwidth=1000pt, paperheight=2000pt]{geometry} \begin{document} \includegraphics{all.1} \end{document} %%% Local Variables: %%% mode: latex %%% TeX-master: t %%% End: mlpost-0.8.1/examples/editor2.ml0000644000443600002640000001550711365367177015751 0ustar kanigdemons(**************************************************************************) (* 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.1/examples/lattice_lablgtk.ml0000644000443600002640000000533511365367177017524 0ustar kanigdemonsopen 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.1/examples/index.html0000644000443600002640000000144411365367177016037 0ustar kanigdemons Mlpost Examples Section

Mlpost Examples Section

Boxes

Paths

Trees

Labels

Automata

Color

Radars

Function plot

Other and more complex examples

Include png pictures

Contributions

Mlpost_dot contrib

mlpost-0.8.1/examples/powered-by-caml.128x58.png0000644000443600002640000000612511365367177020416 0ustar kanigdemons‰PNG  IHDR€:O±¡êPLTEÿÿÿffÿÌffggÿjjÿnnÿppÿssÿuuÿwwÿxxÿzzÿ}}ÿÿ‚‚ÿ……ÿ‡‡ÿˆˆÿŠŠÿŒŒÿÿ‘‘ÿ••ÿ——ÿ™™ÿ››ÿœœÿ¡¡ÿ££ÿ©©ÿ««ÿ­­ÿ®®ÿ°°ÿ³³ÿ¸¸ÿ»»ÿ½½ÿ¾¾ÿÁÁÿÂÂÿÄÄÿÉÉÿÊÊÿÌÌÿÓÓÿÔÔÿÖÖÿØØÿÚÚÿÝÝÿßßÿààÿããÿååÿææÿééÿëëÿììÿîîÿòòÿõõÿ÷÷ÿøøÿúúÿýýÿþþÿÉdd½^^¹\\NNËffÊeeÇddÆccÄbbÂaa¿``»^^º]]·\\¶[[³ZZ²YY®WW«VVªUU¨TT¦SS£RR›NN–KK”JJ’IIHHŒFF‹FFˆDD‡DD…CC‚AA4ÍhhÌggÂbbžPPe33“KKy>>g55ÎkkÍjjY..¸``a33ÎmmªZZ¤WW¾eeÏooÏppUUÐrr@##Ñtto>>ÂmmºhhÑvvˆMMÒwwÒyyÔ||ŒRRÓ||½ppÕ€€Ô}KKÖƒƒÕ‚‚×……Òƒƒ×‡‡×ˆˆØ‰‰´ssØ‹‹¦kkÙÙŽŽÎ‡‡W::’bb‡[[Û””Ö‘‘Œ__¼€€Ü——©ttÝ™™N66Þ››Ýšš‹aaÞÌ‘‘ߟŸß  Ùœœ±€€á¤¤hh㪪ڣ£Ö  štt㬬Ĕ”䯯–ssrXXæ²²ƒffçµµÚ««ç··É  •xxeRRé¾¾¸™™É¨¨ìÆÆêÅÅ¥‹‹íÈÈxffîËËíÊʆssîÍÍÖ¸¸Ã¨¨ïÏÏêËËâÄÄ»¤¤ðÓÓ­™™èÎÎî®óÚÚòÙÙâË˨——ôÞÞóÝÝêÕÕšöâ⧛›¢––÷ææöååëÜÜȼ¼ôææØÌÌøëëïââöêêùîîúññÞÖÖûóóöîîÍÆÆüõõûõõöññìççüøøúööæââðííýûûù÷÷÷õõòððþýýýüüÿÿÿcfõùÿtRNSÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿfüŠYbKGDÿ¥òÅ pHYsHHFÉk> vpAg€:.Ëw¨lIDATXÃÅ™ \UÇ߬¶²,8˜£®ŠŒ8%« ;¬Œ°+ Ç’‚€š¢x¥¥æ®š‚E‡&%á…Šiž¦–VZf™ZšixTÞ~²Ó´PSÃóó)ÍýôÞ\;3ì²ÀgÁÿóæí›÷ûÎÿÿofÞ‚ûØ€\h`Ó4´¼ÈúŽk¥#-Ðôf,bQþönŒ¢ÀX|mKtÈ@Ôw$D·5<„5„5 jÁ&8D è'w ¯õ6Qjcà+ÊÒ1¬E`³ˆ¸dçokÞ¨彧Ð;’¸ØέpÒ&ðŽ¸zqv{/éçHŠ! íº9X‘ [IhµÖ 8á’£j€BôhrptiŒºà¡k @‹GОŽô’cMÍY‡ØhSÀ¤ÇšvLl‡9@bF΄™cáÇ.VÙ!šŠó΢yUÙg|‘5£à>àŒ|å#Õ8l-M6 º1&‡1a‹Ã}X´ÝUÆ;cG-9(Œâ·2,³›¡Sá­sua|x+X‰G1RD§€ ‹~2CCâ1hŠpB$DÁ·`« ©SPÀ‚I!@& y˜0+`CÓ .À@À=Šß«@ ¾B\>HŽ d<À~…PѷЇLc"Òà`O!àÛŠùh®D¼H'¦ r§å)ÀAÏ'œ§$äñp¾ Oö`QøË(`ç·MlÕë«Æ~2^ Œñ¡_%~2œãcÒ6Þ—~} ç?ÜÁ—û5¢jÐÞïöÀ¬nFª,ß{ìà÷• îLòÀ™Ò/Jòÿ[£ãŠ¢h¶Ö²$£LÀHÛ×¥>õc ºáBõBÂéMtí~ªàªx`Ïú™º>£ ;•gÊNÃïGNÜªÒ ­WNB°iÜèkàè´ÂÂ}(öëgºt.§Ó¥Ó¹R³i Õµ›I‚ ()fŠ"Ìt( /Éœ9” B)Î7ÀsÞåó¦ÌÛväඒI:É\³n¨ÏÁ¤I \¾°rÁŒòx1{r&-/Õ™7iRŽKç6gNîvy0zŠ…áÃò¨àpŠîŽa’¾B Øòôž©:¹rsÒ–UTì€eÆ(õNˆzü½‰YLB‚‹G€Ÿ³³2Ó´ºÞ#ƉÃEjôY÷ó ¥’‘hù¡ë=J°{DîZ'¤ žxí¶ø;r´žSé+ŸŠêÀh.Ç¿Ì1 ¤¦¥gd¤ð(éCŸ¿+{[¸ñq;_pŠžB^hïþÙ8¬{š.åñá3R@æð9î{\>׌ü@`I£I”¡•½×€QXj‚Ê£/çê2zL˜òþÆìtÐkäV÷8ä„Q¯'”Û¸82Cí‚'j àˆ4JQúˆ$MR[:©g¯á.ß¹5+55­gÏÞ£v(~åpEÌ1~Ö>’ÌÁVéá4(LSàÖæ%}õí±—ef>1h`ÖÐênE}(""jÞ,Zzé;ì<,ŸqäÖ»; =üjÉ‘M"¥%š®ÍL1ʹëk³¾¼ ξ4pÚûzÀpuáàÝ~ÕwĴ£¥%·ë¦ 8Yüìe¸ù¼ûb™+ù3nƒÓcÞó§~\{½:HËtd›,çÁ•âläü¿¦9 7—æ½~€5çýèÿØö!aqy8bÛ·îŸ$ºaó´9Þmο Oþ`Á ?‰'q6º•>Ì./T Kµ›7mÙ¡SdT”ææþ¼çN¢ÆŸ½/e3ß…ÓÇ@wÄ¡W+|¡·ðe•b­V©ÂêÞ‘Mþ%ÒÞ¢ nŽw/ÕŠ‹ÕlGSHÁ`€S[å®ÀõéÃI) š·½²€®j ƒTà.ªLY_ÁÍÚD°‰ÊÅjÅr=¼¦[8+•/É)E•{”ƒ=)ß¡bYþx؈‘Í"~´0¯ª²0ªV|­¢ÎÊVY®¯ò‡Eå…u®ÉÇAåõý%K÷-yæ7˜‰› Ÿžâ¿,”õ½üesiþØ £+ý‡Ÿø-ÌÿŠM;üáy€ò$xƒ|íÔ9ø‹»L9u³ÒÃqþÿÓJCàƒ»žî{Эu¯*”zÑ­1@½Ûÿ°GBªôËÃ%tEXtdate:create2010-04-12T22:47:48+02:00]Œ-%tEXtdate:modify2010-02-12T16:30:16+01:00ÌXÉIEND®B`‚mlpost-0.8.1/examples/prototype.js0000644000443600002640000042111611365367177016447 0ustar kanigdemons/* Prototype JavaScript framework, version 1.6.1 * (c) 2005-2009 Sam Stephenson * * Prototype is freely distributable under the terms of an MIT-style license. * For details, see the Prototype web site: http://www.prototypejs.org/ * *--------------------------------------------------------------------------*/ var Prototype = { Version: '1.6.1', Browser: (function(){ var ua = navigator.userAgent; var isOpera = Object.prototype.toString.call(window.opera) == '[object Opera]'; return { IE: !!window.attachEvent && !isOpera, Opera: isOpera, WebKit: ua.indexOf('AppleWebKit/') > -1, Gecko: ua.indexOf('Gecko') > -1 && ua.indexOf('KHTML') === -1, MobileSafari: /Apple.*Mobile.*Safari/.test(ua) } })(), BrowserFeatures: { XPath: !!document.evaluate, SelectorsAPI: !!document.querySelector, ElementExtensions: (function() { var constructor = window.Element || window.HTMLElement; return !!(constructor && constructor.prototype); })(), SpecificElementExtensions: (function() { if (typeof window.HTMLDivElement !== 'undefined') return true; var div = document.createElement('div'); var form = document.createElement('form'); var isSupported = false; if (div['__proto__'] && (div['__proto__'] !== form['__proto__'])) { isSupported = true; } div = form = null; return isSupported; })() }, ScriptFragment: ']*>([\\S\\s]*?)<\/script>', JSONFilter: /^\/\*-secure-([\s\S]*)\*\/\s*$/, emptyFunction: function() { }, K: function(x) { return x } }; if (Prototype.Browser.MobileSafari) Prototype.BrowserFeatures.SpecificElementExtensions = false; var Abstract = { }; var Try = { these: function() { var returnValue; for (var i = 0, length = arguments.length; i < length; i++) { var lambda = arguments[i]; try { returnValue = lambda(); break; } catch (e) { } } return returnValue; } }; /* Based on Alex Arnell's inheritance implementation. */ var Class = (function() { function subclass() {}; function create() { var parent = null, properties = $A(arguments); if (Object.isFunction(properties[0])) parent = properties.shift(); function klass() { this.initialize.apply(this, arguments); } Object.extend(klass, Class.Methods); klass.superclass = parent; klass.subclasses = []; if (parent) { subclass.prototype = parent.prototype; klass.prototype = new subclass; parent.subclasses.push(klass); } for (var i = 0; i < properties.length; i++) klass.addMethods(properties[i]); if (!klass.prototype.initialize) klass.prototype.initialize = Prototype.emptyFunction; klass.prototype.constructor = klass; return klass; } function addMethods(source) { var ancestor = this.superclass && this.superclass.prototype; var properties = Object.keys(source); if (!Object.keys({ toString: true }).length) { if (source.toString != Object.prototype.toString) properties.push("toString"); if (source.valueOf != Object.prototype.valueOf) properties.push("valueOf"); } for (var i = 0, length = properties.length; i < length; i++) { var property = properties[i], value = source[property]; if (ancestor && Object.isFunction(value) && value.argumentNames().first() == "$super") { var method = value; value = (function(m) { return function() { return ancestor[m].apply(this, arguments); }; })(property).wrap(method); value.valueOf = method.valueOf.bind(method); value.toString = method.toString.bind(method); } this.prototype[property] = value; } return this; } return { create: create, Methods: { addMethods: addMethods } }; })(); (function() { var _toString = Object.prototype.toString; function extend(destination, source) { for (var property in source) destination[property] = source[property]; return destination; } function inspect(object) { try { if (isUndefined(object)) return 'undefined'; if (object === null) return 'null'; return object.inspect ? object.inspect() : String(object); } catch (e) { if (e instanceof RangeError) return '...'; throw e; } } function toJSON(object) { var type = typeof object; switch (type) { case 'undefined': case 'function': case 'unknown': return; case 'boolean': return object.toString(); } if (object === null) return 'null'; if (object.toJSON) return object.toJSON(); if (isElement(object)) return; var results = []; for (var property in object) { var value = toJSON(object[property]); if (!isUndefined(value)) results.push(property.toJSON() + ': ' + value); } return '{' + results.join(', ') + '}'; } function toQueryString(object) { return $H(object).toQueryString(); } function toHTML(object) { return object && object.toHTML ? object.toHTML() : String.interpret(object); } function keys(object) { var results = []; for (var property in object) results.push(property); return results; } function values(object) { var results = []; for (var property in object) results.push(object[property]); return results; } function clone(object) { return extend({ }, object); } function isElement(object) { return !!(object && object.nodeType == 1); } function isArray(object) { return _toString.call(object) == "[object Array]"; } function isHash(object) { return object instanceof Hash; } function isFunction(object) { return typeof object === "function"; } function isString(object) { return _toString.call(object) == "[object String]"; } function isNumber(object) { return _toString.call(object) == "[object Number]"; } function isUndefined(object) { return typeof object === "undefined"; } extend(Object, { extend: extend, inspect: inspect, toJSON: toJSON, toQueryString: toQueryString, toHTML: toHTML, keys: keys, values: values, clone: clone, isElement: isElement, isArray: isArray, isHash: isHash, isFunction: isFunction, isString: isString, isNumber: isNumber, isUndefined: isUndefined }); })(); Object.extend(Function.prototype, (function() { var slice = Array.prototype.slice; function update(array, args) { var arrayLength = array.length, length = args.length; while (length--) array[arrayLength + length] = args[length]; return array; } function merge(array, args) { array = slice.call(array, 0); return update(array, args); } function argumentNames() { var names = this.toString().match(/^[\s\(]*function[^(]*\(([^)]*)\)/)[1] .replace(/\/\/.*?[\r\n]|\/\*(?:.|[\r\n])*?\*\//g, '') .replace(/\s+/g, '').split(','); return names.length == 1 && !names[0] ? [] : names; } function bind(context) { if (arguments.length < 2 && Object.isUndefined(arguments[0])) return this; var __method = this, args = slice.call(arguments, 1); return function() { var a = merge(args, arguments); return __method.apply(context, a); } } function bindAsEventListener(context) { var __method = this, args = slice.call(arguments, 1); return function(event) { var a = update([event || window.event], args); return __method.apply(context, a); } } function curry() { if (!arguments.length) return this; var __method = this, args = slice.call(arguments, 0); return function() { var a = merge(args, arguments); return __method.apply(this, a); } } function delay(timeout) { var __method = this, args = slice.call(arguments, 1); timeout = timeout * 1000 return window.setTimeout(function() { return __method.apply(__method, args); }, timeout); } function defer() { var args = update([0.01], arguments); return this.delay.apply(this, args); } function wrap(wrapper) { var __method = this; return function() { var a = update([__method.bind(this)], arguments); return wrapper.apply(this, a); } } function methodize() { if (this._methodized) return this._methodized; var __method = this; return this._methodized = function() { var a = update([this], arguments); return __method.apply(null, a); }; } return { argumentNames: argumentNames, bind: bind, bindAsEventListener: bindAsEventListener, curry: curry, delay: delay, defer: defer, wrap: wrap, methodize: methodize } })()); Date.prototype.toJSON = function() { return '"' + this.getUTCFullYear() + '-' + (this.getUTCMonth() + 1).toPaddedString(2) + '-' + this.getUTCDate().toPaddedString(2) + 'T' + this.getUTCHours().toPaddedString(2) + ':' + this.getUTCMinutes().toPaddedString(2) + ':' + this.getUTCSeconds().toPaddedString(2) + 'Z"'; }; RegExp.prototype.match = RegExp.prototype.test; RegExp.escape = function(str) { return String(str).replace(/([.*+?^=!:${}()|[\]\/\\])/g, '\\$1'); }; var PeriodicalExecuter = Class.create({ initialize: function(callback, frequency) { this.callback = callback; this.frequency = frequency; this.currentlyExecuting = false; this.registerCallback(); }, registerCallback: function() { this.timer = setInterval(this.onTimerEvent.bind(this), this.frequency * 1000); }, execute: function() { this.callback(this); }, stop: function() { if (!this.timer) return; clearInterval(this.timer); this.timer = null; }, onTimerEvent: function() { if (!this.currentlyExecuting) { try { this.currentlyExecuting = true; this.execute(); this.currentlyExecuting = false; } catch(e) { this.currentlyExecuting = false; throw e; } } } }); Object.extend(String, { interpret: function(value) { return value == null ? '' : String(value); }, specialChar: { '\b': '\\b', '\t': '\\t', '\n': '\\n', '\f': '\\f', '\r': '\\r', '\\': '\\\\' } }); Object.extend(String.prototype, (function() { function prepareReplacement(replacement) { if (Object.isFunction(replacement)) return replacement; var template = new Template(replacement); return function(match) { return template.evaluate(match) }; } function gsub(pattern, replacement) { var result = '', source = this, match; replacement = prepareReplacement(replacement); if (Object.isString(pattern)) pattern = RegExp.escape(pattern); if (!(pattern.length || pattern.source)) { replacement = replacement(''); return replacement + source.split('').join(replacement) + replacement; } while (source.length > 0) { if (match = source.match(pattern)) { result += source.slice(0, match.index); result += String.interpret(replacement(match)); source = source.slice(match.index + match[0].length); } else { result += source, source = ''; } } return result; } function sub(pattern, replacement, count) { replacement = prepareReplacement(replacement); count = Object.isUndefined(count) ? 1 : count; return this.gsub(pattern, function(match) { if (--count < 0) return match[0]; return replacement(match); }); } function scan(pattern, iterator) { this.gsub(pattern, iterator); return String(this); } function truncate(length, truncation) { length = length || 30; truncation = Object.isUndefined(truncation) ? '...' : truncation; return this.length > length ? this.slice(0, length - truncation.length) + truncation : String(this); } function strip() { return this.replace(/^\s+/, '').replace(/\s+$/, ''); } function stripTags() { return this.replace(/<\w+(\s+("[^"]*"|'[^']*'|[^>])+)?>|<\/\w+>/gi, ''); } function stripScripts() { return this.replace(new RegExp(Prototype.ScriptFragment, 'img'), ''); } function extractScripts() { var matchAll = new RegExp(Prototype.ScriptFragment, 'img'); var matchOne = new RegExp(Prototype.ScriptFragment, 'im'); return (this.match(matchAll) || []).map(function(scriptTag) { return (scriptTag.match(matchOne) || ['', ''])[1]; }); } function evalScripts() { return this.extractScripts().map(function(script) { return eval(script) }); } function escapeHTML() { return this.replace(/&/g,'&').replace(//g,'>'); } function unescapeHTML() { return this.stripTags().replace(/</g,'<').replace(/>/g,'>').replace(/&/g,'&'); } function toQueryParams(separator) { var match = this.strip().match(/([^?#]*)(#.*)?$/); if (!match) return { }; return match[1].split(separator || '&').inject({ }, function(hash, pair) { if ((pair = pair.split('='))[0]) { var key = decodeURIComponent(pair.shift()); var value = pair.length > 1 ? pair.join('=') : pair[0]; if (value != undefined) value = decodeURIComponent(value); if (key in hash) { if (!Object.isArray(hash[key])) hash[key] = [hash[key]]; hash[key].push(value); } else hash[key] = value; } return hash; }); } function toArray() { return this.split(''); } function succ() { return this.slice(0, this.length - 1) + String.fromCharCode(this.charCodeAt(this.length - 1) + 1); } function times(count) { return count < 1 ? '' : new Array(count + 1).join(this); } function camelize() { var parts = this.split('-'), len = parts.length; if (len == 1) return parts[0]; var camelized = this.charAt(0) == '-' ? parts[0].charAt(0).toUpperCase() + parts[0].substring(1) : parts[0]; for (var i = 1; i < len; i++) camelized += parts[i].charAt(0).toUpperCase() + parts[i].substring(1); return camelized; } function capitalize() { return this.charAt(0).toUpperCase() + this.substring(1).toLowerCase(); } function underscore() { return this.replace(/::/g, '/') .replace(/([A-Z]+)([A-Z][a-z])/g, '$1_$2') .replace(/([a-z\d])([A-Z])/g, '$1_$2') .replace(/-/g, '_') .toLowerCase(); } function dasherize() { return this.replace(/_/g, '-'); } function inspect(useDoubleQuotes) { var escapedString = this.replace(/[\x00-\x1f\\]/g, function(character) { if (character in String.specialChar) { return String.specialChar[character]; } return '\\u00' + character.charCodeAt().toPaddedString(2, 16); }); if (useDoubleQuotes) return '"' + escapedString.replace(/"/g, '\\"') + '"'; return "'" + escapedString.replace(/'/g, '\\\'') + "'"; } function toJSON() { return this.inspect(true); } function unfilterJSON(filter) { return this.replace(filter || Prototype.JSONFilter, '$1'); } function isJSON() { var str = this; if (str.blank()) return false; str = this.replace(/\\./g, '@').replace(/"[^"\\\n\r]*"/g, ''); return (/^[,:{}\[\]0-9.\-+Eaeflnr-u \n\r\t]*$/).test(str); } function evalJSON(sanitize) { var json = this.unfilterJSON(); try { if (!sanitize || json.isJSON()) return eval('(' + json + ')'); } catch (e) { } throw new SyntaxError('Badly formed JSON string: ' + this.inspect()); } function include(pattern) { return this.indexOf(pattern) > -1; } function startsWith(pattern) { return this.indexOf(pattern) === 0; } function endsWith(pattern) { var d = this.length - pattern.length; return d >= 0 && this.lastIndexOf(pattern) === d; } function empty() { return this == ''; } function blank() { return /^\s*$/.test(this); } function interpolate(object, pattern) { return new Template(this, pattern).evaluate(object); } return { gsub: gsub, sub: sub, scan: scan, truncate: truncate, strip: String.prototype.trim ? String.prototype.trim : strip, stripTags: stripTags, stripScripts: stripScripts, extractScripts: extractScripts, evalScripts: evalScripts, escapeHTML: escapeHTML, unescapeHTML: unescapeHTML, toQueryParams: toQueryParams, parseQuery: toQueryParams, toArray: toArray, succ: succ, times: times, camelize: camelize, capitalize: capitalize, underscore: underscore, dasherize: dasherize, inspect: inspect, toJSON: toJSON, unfilterJSON: unfilterJSON, isJSON: isJSON, evalJSON: evalJSON, include: include, startsWith: startsWith, endsWith: endsWith, empty: empty, blank: blank, interpolate: interpolate }; })()); var Template = Class.create({ initialize: function(template, pattern) { this.template = template.toString(); this.pattern = pattern || Template.Pattern; }, evaluate: function(object) { if (object && Object.isFunction(object.toTemplateReplacements)) object = object.toTemplateReplacements(); return this.template.gsub(this.pattern, function(match) { if (object == null) return (match[1] + ''); var before = match[1] || ''; if (before == '\\') return match[2]; var ctx = object, expr = match[3]; var pattern = /^([^.[]+|\[((?:.*?[^\\])?)\])(\.|\[|$)/; match = pattern.exec(expr); if (match == null) return before; while (match != null) { var comp = match[1].startsWith('[') ? match[2].replace(/\\\\]/g, ']') : match[1]; ctx = ctx[comp]; if (null == ctx || '' == match[3]) break; expr = expr.substring('[' == match[3] ? match[1].length : match[0].length); match = pattern.exec(expr); } return before + String.interpret(ctx); }); } }); Template.Pattern = /(^|.|\r|\n)(#\{(.*?)\})/; var $break = { }; var Enumerable = (function() { function each(iterator, context) { var index = 0; try { this._each(function(value) { iterator.call(context, value, index++); }); } catch (e) { if (e != $break) throw e; } return this; } function eachSlice(number, iterator, context) { var index = -number, slices = [], array = this.toArray(); if (number < 1) return array; while ((index += number) < array.length) slices.push(array.slice(index, index+number)); return slices.collect(iterator, context); } function all(iterator, context) { iterator = iterator || Prototype.K; var result = true; this.each(function(value, index) { result = result && !!iterator.call(context, value, index); if (!result) throw $break; }); return result; } function any(iterator, context) { iterator = iterator || Prototype.K; var result = false; this.each(function(value, index) { if (result = !!iterator.call(context, value, index)) throw $break; }); return result; } function collect(iterator, context) { iterator = iterator || Prototype.K; var results = []; this.each(function(value, index) { results.push(iterator.call(context, value, index)); }); return results; } function detect(iterator, context) { var result; this.each(function(value, index) { if (iterator.call(context, value, index)) { result = value; throw $break; } }); return result; } function findAll(iterator, context) { var results = []; this.each(function(value, index) { if (iterator.call(context, value, index)) results.push(value); }); return results; } function grep(filter, iterator, context) { iterator = iterator || Prototype.K; var results = []; if (Object.isString(filter)) filter = new RegExp(RegExp.escape(filter)); this.each(function(value, index) { if (filter.match(value)) results.push(iterator.call(context, value, index)); }); return results; } function include(object) { if (Object.isFunction(this.indexOf)) if (this.indexOf(object) != -1) return true; var found = false; this.each(function(value) { if (value == object) { found = true; throw $break; } }); return found; } function inGroupsOf(number, fillWith) { fillWith = Object.isUndefined(fillWith) ? null : fillWith; return this.eachSlice(number, function(slice) { while(slice.length < number) slice.push(fillWith); return slice; }); } function inject(memo, iterator, context) { this.each(function(value, index) { memo = iterator.call(context, memo, value, index); }); return memo; } function invoke(method) { var args = $A(arguments).slice(1); return this.map(function(value) { return value[method].apply(value, args); }); } function max(iterator, context) { iterator = iterator || Prototype.K; var result; this.each(function(value, index) { value = iterator.call(context, value, index); if (result == null || value >= result) result = value; }); return result; } function min(iterator, context) { iterator = iterator || Prototype.K; var result; this.each(function(value, index) { value = iterator.call(context, value, index); if (result == null || value < result) result = value; }); return result; } function partition(iterator, context) { iterator = iterator || Prototype.K; var trues = [], falses = []; this.each(function(value, index) { (iterator.call(context, value, index) ? trues : falses).push(value); }); return [trues, falses]; } function pluck(property) { var results = []; this.each(function(value) { results.push(value[property]); }); return results; } function reject(iterator, context) { var results = []; this.each(function(value, index) { if (!iterator.call(context, value, index)) results.push(value); }); return results; } function sortBy(iterator, context) { return this.map(function(value, index) { return { value: value, criteria: iterator.call(context, value, index) }; }).sort(function(left, right) { var a = left.criteria, b = right.criteria; return a < b ? -1 : a > b ? 1 : 0; }).pluck('value'); } function toArray() { return this.map(); } function zip() { var iterator = Prototype.K, args = $A(arguments); if (Object.isFunction(args.last())) iterator = args.pop(); var collections = [this].concat(args).map($A); return this.map(function(value, index) { return iterator(collections.pluck(index)); }); } function size() { return this.toArray().length; } function inspect() { return '#'; } return { each: each, eachSlice: eachSlice, all: all, every: all, any: any, some: any, collect: collect, map: collect, detect: detect, findAll: findAll, select: findAll, filter: findAll, grep: grep, include: include, member: include, inGroupsOf: inGroupsOf, inject: inject, invoke: invoke, max: max, min: min, partition: partition, pluck: pluck, reject: reject, sortBy: sortBy, toArray: toArray, entries: toArray, zip: zip, size: size, inspect: inspect, find: detect }; })(); function $A(iterable) { if (!iterable) return []; if ('toArray' in Object(iterable)) return iterable.toArray(); var length = iterable.length || 0, results = new Array(length); while (length--) results[length] = iterable[length]; return results; } function $w(string) { if (!Object.isString(string)) return []; string = string.strip(); return string ? string.split(/\s+/) : []; } Array.from = $A; (function() { var arrayProto = Array.prototype, slice = arrayProto.slice, _each = arrayProto.forEach; // use native browser JS 1.6 implementation if available function each(iterator) { for (var i = 0, length = this.length; i < length; i++) iterator(this[i]); } if (!_each) _each = each; function clear() { this.length = 0; return this; } function first() { return this[0]; } function last() { return this[this.length - 1]; } function compact() { return this.select(function(value) { return value != null; }); } function flatten() { return this.inject([], function(array, value) { if (Object.isArray(value)) return array.concat(value.flatten()); array.push(value); return array; }); } function without() { var values = slice.call(arguments, 0); return this.select(function(value) { return !values.include(value); }); } function reverse(inline) { return (inline !== false ? this : this.toArray())._reverse(); } function uniq(sorted) { return this.inject([], function(array, value, index) { if (0 == index || (sorted ? array.last() != value : !array.include(value))) array.push(value); return array; }); } function intersect(array) { return this.uniq().findAll(function(item) { return array.detect(function(value) { return item === value }); }); } function clone() { return slice.call(this, 0); } function size() { return this.length; } function inspect() { return '[' + this.map(Object.inspect).join(', ') + ']'; } function toJSON() { var results = []; this.each(function(object) { var value = Object.toJSON(object); if (!Object.isUndefined(value)) results.push(value); }); return '[' + results.join(', ') + ']'; } function indexOf(item, i) { i || (i = 0); var length = this.length; if (i < 0) i = length + i; for (; i < length; i++) if (this[i] === item) return i; return -1; } function lastIndexOf(item, i) { i = isNaN(i) ? this.length : (i < 0 ? this.length + i : i) + 1; var n = this.slice(0, i).reverse().indexOf(item); return (n < 0) ? n : i - n - 1; } function concat() { var array = slice.call(this, 0), item; for (var i = 0, length = arguments.length; i < length; i++) { item = arguments[i]; if (Object.isArray(item) && !('callee' in item)) { for (var j = 0, arrayLength = item.length; j < arrayLength; j++) array.push(item[j]); } else { array.push(item); } } return array; } Object.extend(arrayProto, Enumerable); if (!arrayProto._reverse) arrayProto._reverse = arrayProto.reverse; Object.extend(arrayProto, { _each: _each, clear: clear, first: first, last: last, compact: compact, flatten: flatten, without: without, reverse: reverse, uniq: uniq, intersect: intersect, clone: clone, toArray: clone, size: size, inspect: inspect, toJSON: toJSON }); var CONCAT_ARGUMENTS_BUGGY = (function() { return [].concat(arguments)[0][0] !== 1; })(1,2) if (CONCAT_ARGUMENTS_BUGGY) arrayProto.concat = concat; if (!arrayProto.indexOf) arrayProto.indexOf = indexOf; if (!arrayProto.lastIndexOf) arrayProto.lastIndexOf = lastIndexOf; })(); function $H(object) { return new Hash(object); }; var Hash = Class.create(Enumerable, (function() { function initialize(object) { this._object = Object.isHash(object) ? object.toObject() : Object.clone(object); } function _each(iterator) { for (var key in this._object) { var value = this._object[key], pair = [key, value]; pair.key = key; pair.value = value; iterator(pair); } } function set(key, value) { return this._object[key] = value; } function get(key) { if (this._object[key] !== Object.prototype[key]) return this._object[key]; } function unset(key) { var value = this._object[key]; delete this._object[key]; return value; } function toObject() { return Object.clone(this._object); } function keys() { return this.pluck('key'); } function values() { return this.pluck('value'); } function index(value) { var match = this.detect(function(pair) { return pair.value === value; }); return match && match.key; } function merge(object) { return this.clone().update(object); } function update(object) { return new Hash(object).inject(this, function(result, pair) { result.set(pair.key, pair.value); return result; }); } function toQueryPair(key, value) { if (Object.isUndefined(value)) return key; return key + '=' + encodeURIComponent(String.interpret(value)); } function toQueryString() { return this.inject([], function(results, pair) { var key = encodeURIComponent(pair.key), values = pair.value; if (values && typeof values == 'object') { if (Object.isArray(values)) return results.concat(values.map(toQueryPair.curry(key))); } else results.push(toQueryPair(key, values)); return results; }).join('&'); } function inspect() { return '#'; } function toJSON() { return Object.toJSON(this.toObject()); } function clone() { return new Hash(this); } return { initialize: initialize, _each: _each, set: set, get: get, unset: unset, toObject: toObject, toTemplateReplacements: toObject, keys: keys, values: values, index: index, merge: merge, update: update, toQueryString: toQueryString, inspect: inspect, toJSON: toJSON, clone: clone }; })()); Hash.from = $H; Object.extend(Number.prototype, (function() { function toColorPart() { return this.toPaddedString(2, 16); } function succ() { return this + 1; } function times(iterator, context) { $R(0, this, true).each(iterator, context); return this; } function toPaddedString(length, radix) { var string = this.toString(radix || 10); return '0'.times(length - string.length) + string; } function toJSON() { return isFinite(this) ? this.toString() : 'null'; } function abs() { return Math.abs(this); } function round() { return Math.round(this); } function ceil() { return Math.ceil(this); } function floor() { return Math.floor(this); } return { toColorPart: toColorPart, succ: succ, times: times, toPaddedString: toPaddedString, toJSON: toJSON, abs: abs, round: round, ceil: ceil, floor: floor }; })()); function $R(start, end, exclusive) { return new ObjectRange(start, end, exclusive); } var ObjectRange = Class.create(Enumerable, (function() { function initialize(start, end, exclusive) { this.start = start; this.end = end; this.exclusive = exclusive; } function _each(iterator) { var value = this.start; while (this.include(value)) { iterator(value); value = value.succ(); } } function include(value) { if (value < this.start) return false; if (this.exclusive) return value < this.end; return value <= this.end; } return { initialize: initialize, _each: _each, include: include }; })()); var Ajax = { getTransport: function() { return Try.these( function() {return new XMLHttpRequest()}, function() {return new ActiveXObject('Msxml2.XMLHTTP')}, function() {return new ActiveXObject('Microsoft.XMLHTTP')} ) || false; }, activeRequestCount: 0 }; Ajax.Responders = { responders: [], _each: function(iterator) { this.responders._each(iterator); }, register: function(responder) { if (!this.include(responder)) this.responders.push(responder); }, unregister: function(responder) { this.responders = this.responders.without(responder); }, dispatch: function(callback, request, transport, json) { this.each(function(responder) { if (Object.isFunction(responder[callback])) { try { responder[callback].apply(responder, [request, transport, json]); } catch (e) { } } }); } }; Object.extend(Ajax.Responders, Enumerable); Ajax.Responders.register({ onCreate: function() { Ajax.activeRequestCount++ }, onComplete: function() { Ajax.activeRequestCount-- } }); Ajax.Base = Class.create({ initialize: function(options) { this.options = { method: 'post', asynchronous: true, contentType: 'application/x-www-form-urlencoded', encoding: 'UTF-8', parameters: '', evalJSON: true, evalJS: true }; Object.extend(this.options, options || { }); this.options.method = this.options.method.toLowerCase(); if (Object.isString(this.options.parameters)) this.options.parameters = this.options.parameters.toQueryParams(); else if (Object.isHash(this.options.parameters)) this.options.parameters = this.options.parameters.toObject(); } }); Ajax.Request = Class.create(Ajax.Base, { _complete: false, initialize: function($super, url, options) { $super(options); this.transport = Ajax.getTransport(); this.request(url); }, request: function(url) { this.url = url; this.method = this.options.method; var params = Object.clone(this.options.parameters); if (!['get', 'post'].include(this.method)) { params['_method'] = this.method; this.method = 'post'; } this.parameters = params; if (params = Object.toQueryString(params)) { if (this.method == 'get') this.url += (this.url.include('?') ? '&' : '?') + params; else if (/Konqueror|Safari|KHTML/.test(navigator.userAgent)) params += '&_='; } try { var response = new Ajax.Response(this); if (this.options.onCreate) this.options.onCreate(response); Ajax.Responders.dispatch('onCreate', this, response); this.transport.open(this.method.toUpperCase(), this.url, this.options.asynchronous); if (this.options.asynchronous) this.respondToReadyState.bind(this).defer(1); this.transport.onreadystatechange = this.onStateChange.bind(this); this.setRequestHeaders(); this.body = this.method == 'post' ? (this.options.postBody || params) : null; this.transport.send(this.body); /* Force Firefox to handle ready state 4 for synchronous requests */ if (!this.options.asynchronous && this.transport.overrideMimeType) this.onStateChange(); } catch (e) { this.dispatchException(e); } }, onStateChange: function() { var readyState = this.transport.readyState; if (readyState > 1 && !((readyState == 4) && this._complete)) this.respondToReadyState(this.transport.readyState); }, setRequestHeaders: function() { var headers = { 'X-Requested-With': 'XMLHttpRequest', 'X-Prototype-Version': Prototype.Version, 'Accept': 'text/javascript, text/html, application/xml, text/xml, */*' }; if (this.method == 'post') { headers['Content-type'] = this.options.contentType + (this.options.encoding ? '; charset=' + this.options.encoding : ''); /* Force "Connection: close" for older Mozilla browsers to work * around a bug where XMLHttpRequest sends an incorrect * Content-length header. See Mozilla Bugzilla #246651. */ if (this.transport.overrideMimeType && (navigator.userAgent.match(/Gecko\/(\d{4})/) || [0,2005])[1] < 2005) headers['Connection'] = 'close'; } if (typeof this.options.requestHeaders == 'object') { var extras = this.options.requestHeaders; if (Object.isFunction(extras.push)) for (var i = 0, length = extras.length; i < length; i += 2) headers[extras[i]] = extras[i+1]; else $H(extras).each(function(pair) { headers[pair.key] = pair.value }); } for (var name in headers) this.transport.setRequestHeader(name, headers[name]); }, success: function() { var status = this.getStatus(); return !status || (status >= 200 && status < 300); }, getStatus: function() { try { return this.transport.status || 0; } catch (e) { return 0 } }, respondToReadyState: function(readyState) { var state = Ajax.Request.Events[readyState], response = new Ajax.Response(this); if (state == 'Complete') { try { this._complete = true; (this.options['on' + response.status] || this.options['on' + (this.success() ? 'Success' : 'Failure')] || Prototype.emptyFunction)(response, response.headerJSON); } catch (e) { this.dispatchException(e); } var contentType = response.getHeader('Content-type'); if (this.options.evalJS == 'force' || (this.options.evalJS && this.isSameOrigin() && contentType && contentType.match(/^\s*(text|application)\/(x-)?(java|ecma)script(;.*)?\s*$/i))) this.evalResponse(); } try { (this.options['on' + state] || Prototype.emptyFunction)(response, response.headerJSON); Ajax.Responders.dispatch('on' + state, this, response, response.headerJSON); } catch (e) { this.dispatchException(e); } if (state == 'Complete') { this.transport.onreadystatechange = Prototype.emptyFunction; } }, isSameOrigin: function() { var m = this.url.match(/^\s*https?:\/\/[^\/]*/); return !m || (m[0] == '#{protocol}//#{domain}#{port}'.interpolate({ protocol: location.protocol, domain: document.domain, port: location.port ? ':' + location.port : '' })); }, getHeader: function(name) { try { return this.transport.getResponseHeader(name) || null; } catch (e) { return null; } }, evalResponse: function() { try { return eval((this.transport.responseText || '').unfilterJSON()); } catch (e) { this.dispatchException(e); } }, dispatchException: function(exception) { (this.options.onException || Prototype.emptyFunction)(this, exception); Ajax.Responders.dispatch('onException', this, exception); } }); Ajax.Request.Events = ['Uninitialized', 'Loading', 'Loaded', 'Interactive', 'Complete']; Ajax.Response = Class.create({ initialize: function(request){ this.request = request; var transport = this.transport = request.transport, readyState = this.readyState = transport.readyState; if((readyState > 2 && !Prototype.Browser.IE) || readyState == 4) { this.status = this.getStatus(); this.statusText = this.getStatusText(); this.responseText = String.interpret(transport.responseText); this.headerJSON = this._getHeaderJSON(); } if(readyState == 4) { var xml = transport.responseXML; this.responseXML = Object.isUndefined(xml) ? null : xml; this.responseJSON = this._getResponseJSON(); } }, status: 0, statusText: '', getStatus: Ajax.Request.prototype.getStatus, getStatusText: function() { try { return this.transport.statusText || ''; } catch (e) { return '' } }, getHeader: Ajax.Request.prototype.getHeader, getAllHeaders: function() { try { return this.getAllResponseHeaders(); } catch (e) { return null } }, getResponseHeader: function(name) { return this.transport.getResponseHeader(name); }, getAllResponseHeaders: function() { return this.transport.getAllResponseHeaders(); }, _getHeaderJSON: function() { var json = this.getHeader('X-JSON'); if (!json) return null; json = decodeURIComponent(escape(json)); try { return json.evalJSON(this.request.options.sanitizeJSON || !this.request.isSameOrigin()); } catch (e) { this.request.dispatchException(e); } }, _getResponseJSON: function() { var options = this.request.options; if (!options.evalJSON || (options.evalJSON != 'force' && !(this.getHeader('Content-type') || '').include('application/json')) || this.responseText.blank()) return null; try { return this.responseText.evalJSON(options.sanitizeJSON || !this.request.isSameOrigin()); } catch (e) { this.request.dispatchException(e); } } }); Ajax.Updater = Class.create(Ajax.Request, { initialize: function($super, container, url, options) { this.container = { success: (container.success || container), failure: (container.failure || (container.success ? null : container)) }; options = Object.clone(options); var onComplete = options.onComplete; options.onComplete = (function(response, json) { this.updateContent(response.responseText); if (Object.isFunction(onComplete)) onComplete(response, json); }).bind(this); $super(url, options); }, updateContent: function(responseText) { var receiver = this.container[this.success() ? 'success' : 'failure'], options = this.options; if (!options.evalScripts) responseText = responseText.stripScripts(); if (receiver = $(receiver)) { if (options.insertion) { if (Object.isString(options.insertion)) { var insertion = { }; insertion[options.insertion] = responseText; receiver.insert(insertion); } else options.insertion(receiver, responseText); } else receiver.update(responseText); } } }); Ajax.PeriodicalUpdater = Class.create(Ajax.Base, { initialize: function($super, container, url, options) { $super(options); this.onComplete = this.options.onComplete; this.frequency = (this.options.frequency || 2); this.decay = (this.options.decay || 1); this.updater = { }; this.container = container; this.url = url; this.start(); }, start: function() { this.options.onComplete = this.updateComplete.bind(this); this.onTimerEvent(); }, stop: function() { this.updater.options.onComplete = undefined; clearTimeout(this.timer); (this.onComplete || Prototype.emptyFunction).apply(this, arguments); }, updateComplete: function(response) { if (this.options.decay) { this.decay = (response.responseText == this.lastText ? this.decay * this.options.decay : 1); this.lastText = response.responseText; } this.timer = this.onTimerEvent.bind(this).delay(this.decay * this.frequency); }, onTimerEvent: function() { this.updater = new Ajax.Updater(this.container, this.url, this.options); } }); function $(element) { if (arguments.length > 1) { for (var i = 0, elements = [], length = arguments.length; i < length; i++) elements.push($(arguments[i])); return elements; } if (Object.isString(element)) element = document.getElementById(element); return Element.extend(element); } if (Prototype.BrowserFeatures.XPath) { document._getElementsByXPath = function(expression, parentElement) { var results = []; var query = document.evaluate(expression, $(parentElement) || document, null, XPathResult.ORDERED_NODE_SNAPSHOT_TYPE, null); for (var i = 0, length = query.snapshotLength; i < length; i++) results.push(Element.extend(query.snapshotItem(i))); return results; }; } /*--------------------------------------------------------------------------*/ if (!window.Node) var Node = { }; if (!Node.ELEMENT_NODE) { Object.extend(Node, { ELEMENT_NODE: 1, ATTRIBUTE_NODE: 2, TEXT_NODE: 3, CDATA_SECTION_NODE: 4, ENTITY_REFERENCE_NODE: 5, ENTITY_NODE: 6, PROCESSING_INSTRUCTION_NODE: 7, COMMENT_NODE: 8, DOCUMENT_NODE: 9, DOCUMENT_TYPE_NODE: 10, DOCUMENT_FRAGMENT_NODE: 11, NOTATION_NODE: 12 }); } (function(global) { var SETATTRIBUTE_IGNORES_NAME = (function(){ var elForm = document.createElement("form"); var elInput = document.createElement("input"); var root = document.documentElement; elInput.setAttribute("name", "test"); elForm.appendChild(elInput); root.appendChild(elForm); var isBuggy = elForm.elements ? (typeof elForm.elements.test == "undefined") : null; root.removeChild(elForm); elForm = elInput = null; return isBuggy; })(); var element = global.Element; global.Element = function(tagName, attributes) { attributes = attributes || { }; tagName = tagName.toLowerCase(); var cache = Element.cache; if (SETATTRIBUTE_IGNORES_NAME && attributes.name) { tagName = '<' + tagName + ' name="' + attributes.name + '">'; delete attributes.name; return Element.writeAttribute(document.createElement(tagName), attributes); } if (!cache[tagName]) cache[tagName] = Element.extend(document.createElement(tagName)); return Element.writeAttribute(cache[tagName].cloneNode(false), attributes); }; Object.extend(global.Element, element || { }); if (element) global.Element.prototype = element.prototype; })(this); Element.cache = { }; Element.idCounter = 1; Element.Methods = { visible: function(element) { return $(element).style.display != 'none'; }, toggle: function(element) { element = $(element); Element[Element.visible(element) ? 'hide' : 'show'](element); return element; }, hide: function(element) { element = $(element); element.style.display = 'none'; return element; }, show: function(element) { element = $(element); element.style.display = ''; return element; }, remove: function(element) { element = $(element); element.parentNode.removeChild(element); return element; }, update: (function(){ var SELECT_ELEMENT_INNERHTML_BUGGY = (function(){ var el = document.createElement("select"), isBuggy = true; el.innerHTML = ""; if (el.options && el.options[0]) { isBuggy = el.options[0].nodeName.toUpperCase() !== "OPTION"; } el = null; return isBuggy; })(); var TABLE_ELEMENT_INNERHTML_BUGGY = (function(){ try { var el = document.createElement("table"); if (el && el.tBodies) { el.innerHTML = "test"; var isBuggy = typeof el.tBodies[0] == "undefined"; el = null; return isBuggy; } } catch (e) { return true; } })(); var SCRIPT_ELEMENT_REJECTS_TEXTNODE_APPENDING = (function () { var s = document.createElement("script"), isBuggy = false; try { s.appendChild(document.createTextNode("")); isBuggy = !s.firstChild || s.firstChild && s.firstChild.nodeType !== 3; } catch (e) { isBuggy = true; } s = null; return isBuggy; })(); function update(element, content) { element = $(element); if (content && content.toElement) content = content.toElement(); if (Object.isElement(content)) return element.update().insert(content); content = Object.toHTML(content); var tagName = element.tagName.toUpperCase(); if (tagName === 'SCRIPT' && SCRIPT_ELEMENT_REJECTS_TEXTNODE_APPENDING) { element.text = content; return element; } if (SELECT_ELEMENT_INNERHTML_BUGGY || TABLE_ELEMENT_INNERHTML_BUGGY) { if (tagName in Element._insertionTranslations.tags) { while (element.firstChild) { element.removeChild(element.firstChild); } Element._getContentFromAnonymousElement(tagName, content.stripScripts()) .each(function(node) { element.appendChild(node) }); } else { element.innerHTML = content.stripScripts(); } } else { element.innerHTML = content.stripScripts(); } content.evalScripts.bind(content).defer(); return element; } return update; })(), replace: function(element, content) { element = $(element); if (content && content.toElement) content = content.toElement(); else if (!Object.isElement(content)) { content = Object.toHTML(content); var range = element.ownerDocument.createRange(); range.selectNode(element); content.evalScripts.bind(content).defer(); content = range.createContextualFragment(content.stripScripts()); } element.parentNode.replaceChild(content, element); return element; }, insert: function(element, insertions) { element = $(element); if (Object.isString(insertions) || Object.isNumber(insertions) || Object.isElement(insertions) || (insertions && (insertions.toElement || insertions.toHTML))) insertions = {bottom:insertions}; var content, insert, tagName, childNodes; for (var position in insertions) { content = insertions[position]; position = position.toLowerCase(); insert = Element._insertionTranslations[position]; if (content && content.toElement) content = content.toElement(); if (Object.isElement(content)) { insert(element, content); continue; } content = Object.toHTML(content); tagName = ((position == 'before' || position == 'after') ? element.parentNode : element).tagName.toUpperCase(); childNodes = Element._getContentFromAnonymousElement(tagName, content.stripScripts()); if (position == 'top' || position == 'after') childNodes.reverse(); childNodes.each(insert.curry(element)); content.evalScripts.bind(content).defer(); } return element; }, wrap: function(element, wrapper, attributes) { element = $(element); if (Object.isElement(wrapper)) $(wrapper).writeAttribute(attributes || { }); else if (Object.isString(wrapper)) wrapper = new Element(wrapper, attributes); else wrapper = new Element('div', wrapper); if (element.parentNode) element.parentNode.replaceChild(wrapper, element); wrapper.appendChild(element); return wrapper; }, inspect: function(element) { element = $(element); var result = '<' + element.tagName.toLowerCase(); $H({'id': 'id', 'className': 'class'}).each(function(pair) { var property = pair.first(), attribute = pair.last(); var value = (element[property] || '').toString(); if (value) result += ' ' + attribute + '=' + value.inspect(true); }); return result + '>'; }, recursivelyCollect: function(element, property) { element = $(element); var elements = []; while (element = element[property]) if (element.nodeType == 1) elements.push(Element.extend(element)); return elements; }, ancestors: function(element) { return Element.recursivelyCollect(element, 'parentNode'); }, descendants: function(element) { return Element.select(element, "*"); }, firstDescendant: function(element) { element = $(element).firstChild; while (element && element.nodeType != 1) element = element.nextSibling; return $(element); }, immediateDescendants: function(element) { if (!(element = $(element).firstChild)) return []; while (element && element.nodeType != 1) element = element.nextSibling; if (element) return [element].concat($(element).nextSiblings()); return []; }, previousSiblings: function(element) { return Element.recursivelyCollect(element, 'previousSibling'); }, nextSiblings: function(element) { return Element.recursivelyCollect(element, 'nextSibling'); }, siblings: function(element) { element = $(element); return Element.previousSiblings(element).reverse() .concat(Element.nextSiblings(element)); }, match: function(element, selector) { if (Object.isString(selector)) selector = new Selector(selector); return selector.match($(element)); }, up: function(element, expression, index) { element = $(element); if (arguments.length == 1) return $(element.parentNode); var ancestors = Element.ancestors(element); return Object.isNumber(expression) ? ancestors[expression] : Selector.findElement(ancestors, expression, index); }, down: function(element, expression, index) { element = $(element); if (arguments.length == 1) return Element.firstDescendant(element); return Object.isNumber(expression) ? Element.descendants(element)[expression] : Element.select(element, expression)[index || 0]; }, previous: function(element, expression, index) { element = $(element); if (arguments.length == 1) return $(Selector.handlers.previousElementSibling(element)); var previousSiblings = Element.previousSiblings(element); return Object.isNumber(expression) ? previousSiblings[expression] : Selector.findElement(previousSiblings, expression, index); }, next: function(element, expression, index) { element = $(element); if (arguments.length == 1) return $(Selector.handlers.nextElementSibling(element)); var nextSiblings = Element.nextSiblings(element); return Object.isNumber(expression) ? nextSiblings[expression] : Selector.findElement(nextSiblings, expression, index); }, select: function(element) { var args = Array.prototype.slice.call(arguments, 1); return Selector.findChildElements(element, args); }, adjacent: function(element) { var args = Array.prototype.slice.call(arguments, 1); return Selector.findChildElements(element.parentNode, args).without(element); }, identify: function(element) { element = $(element); var id = Element.readAttribute(element, 'id'); if (id) return id; do { id = 'anonymous_element_' + Element.idCounter++ } while ($(id)); Element.writeAttribute(element, 'id', id); return id; }, readAttribute: function(element, name) { element = $(element); if (Prototype.Browser.IE) { var t = Element._attributeTranslations.read; if (t.values[name]) return t.values[name](element, name); if (t.names[name]) name = t.names[name]; if (name.include(':')) { return (!element.attributes || !element.attributes[name]) ? null : element.attributes[name].value; } } return element.getAttribute(name); }, writeAttribute: function(element, name, value) { element = $(element); var attributes = { }, t = Element._attributeTranslations.write; if (typeof name == 'object') attributes = name; else attributes[name] = Object.isUndefined(value) ? true : value; for (var attr in attributes) { name = t.names[attr] || attr; value = attributes[attr]; if (t.values[attr]) name = t.values[attr](element, value); if (value === false || value === null) element.removeAttribute(name); else if (value === true) element.setAttribute(name, name); else element.setAttribute(name, value); } return element; }, getHeight: function(element) { return Element.getDimensions(element).height; }, getWidth: function(element) { return Element.getDimensions(element).width; }, classNames: function(element) { return new Element.ClassNames(element); }, hasClassName: function(element, className) { if (!(element = $(element))) return; var elementClassName = element.className; return (elementClassName.length > 0 && (elementClassName == className || new RegExp("(^|\\s)" + className + "(\\s|$)").test(elementClassName))); }, addClassName: function(element, className) { if (!(element = $(element))) return; if (!Element.hasClassName(element, className)) element.className += (element.className ? ' ' : '') + className; return element; }, removeClassName: function(element, className) { if (!(element = $(element))) return; element.className = element.className.replace( new RegExp("(^|\\s+)" + className + "(\\s+|$)"), ' ').strip(); return element; }, toggleClassName: function(element, className) { if (!(element = $(element))) return; return Element[Element.hasClassName(element, className) ? 'removeClassName' : 'addClassName'](element, className); }, cleanWhitespace: function(element) { element = $(element); var node = element.firstChild; while (node) { var nextNode = node.nextSibling; if (node.nodeType == 3 && !/\S/.test(node.nodeValue)) element.removeChild(node); node = nextNode; } return element; }, empty: function(element) { return $(element).innerHTML.blank(); }, descendantOf: function(element, ancestor) { element = $(element), ancestor = $(ancestor); if (element.compareDocumentPosition) return (element.compareDocumentPosition(ancestor) & 8) === 8; if (ancestor.contains) return ancestor.contains(element) && ancestor !== element; while (element = element.parentNode) if (element == ancestor) return true; return false; }, scrollTo: function(element) { element = $(element); var pos = Element.cumulativeOffset(element); window.scrollTo(pos[0], pos[1]); return element; }, getStyle: function(element, style) { element = $(element); style = style == 'float' ? 'cssFloat' : style.camelize(); var value = element.style[style]; if (!value || value == 'auto') { var css = document.defaultView.getComputedStyle(element, null); value = css ? css[style] : null; } if (style == 'opacity') return value ? parseFloat(value) : 1.0; return value == 'auto' ? null : value; }, getOpacity: function(element) { return $(element).getStyle('opacity'); }, setStyle: function(element, styles) { element = $(element); var elementStyle = element.style, match; if (Object.isString(styles)) { element.style.cssText += ';' + styles; return styles.include('opacity') ? element.setOpacity(styles.match(/opacity:\s*(\d?\.?\d*)/)[1]) : element; } for (var property in styles) if (property == 'opacity') element.setOpacity(styles[property]); else elementStyle[(property == 'float' || property == 'cssFloat') ? (Object.isUndefined(elementStyle.styleFloat) ? 'cssFloat' : 'styleFloat') : property] = styles[property]; return element; }, setOpacity: function(element, value) { element = $(element); element.style.opacity = (value == 1 || value === '') ? '' : (value < 0.00001) ? 0 : value; return element; }, getDimensions: function(element) { element = $(element); var display = Element.getStyle(element, 'display'); if (display != 'none' && display != null) // Safari bug return {width: element.offsetWidth, height: element.offsetHeight}; var els = element.style; var originalVisibility = els.visibility; var originalPosition = els.position; var originalDisplay = els.display; els.visibility = 'hidden'; if (originalPosition != 'fixed') // Switching fixed to absolute causes issues in Safari els.position = 'absolute'; els.display = 'block'; var originalWidth = element.clientWidth; var originalHeight = element.clientHeight; els.display = originalDisplay; els.position = originalPosition; els.visibility = originalVisibility; return {width: originalWidth, height: originalHeight}; }, makePositioned: function(element) { element = $(element); var pos = Element.getStyle(element, 'position'); if (pos == 'static' || !pos) { element._madePositioned = true; element.style.position = 'relative'; if (Prototype.Browser.Opera) { element.style.top = 0; element.style.left = 0; } } return element; }, undoPositioned: function(element) { element = $(element); if (element._madePositioned) { element._madePositioned = undefined; element.style.position = element.style.top = element.style.left = element.style.bottom = element.style.right = ''; } return element; }, makeClipping: function(element) { element = $(element); if (element._overflow) return element; element._overflow = Element.getStyle(element, 'overflow') || 'auto'; if (element._overflow !== 'hidden') element.style.overflow = 'hidden'; return element; }, undoClipping: function(element) { element = $(element); if (!element._overflow) return element; element.style.overflow = element._overflow == 'auto' ? '' : element._overflow; element._overflow = null; return element; }, cumulativeOffset: function(element) { var valueT = 0, valueL = 0; do { valueT += element.offsetTop || 0; valueL += element.offsetLeft || 0; element = element.offsetParent; } while (element); return Element._returnOffset(valueL, valueT); }, positionedOffset: function(element) { var valueT = 0, valueL = 0; do { valueT += element.offsetTop || 0; valueL += element.offsetLeft || 0; element = element.offsetParent; if (element) { if (element.tagName.toUpperCase() == 'BODY') break; var p = Element.getStyle(element, 'position'); if (p !== 'static') break; } } while (element); return Element._returnOffset(valueL, valueT); }, absolutize: function(element) { element = $(element); if (Element.getStyle(element, 'position') == 'absolute') return element; var offsets = Element.positionedOffset(element); var top = offsets[1]; var left = offsets[0]; var width = element.clientWidth; var height = element.clientHeight; element._originalLeft = left - parseFloat(element.style.left || 0); element._originalTop = top - parseFloat(element.style.top || 0); element._originalWidth = element.style.width; element._originalHeight = element.style.height; element.style.position = 'absolute'; element.style.top = top + 'px'; element.style.left = left + 'px'; element.style.width = width + 'px'; element.style.height = height + 'px'; return element; }, relativize: function(element) { element = $(element); if (Element.getStyle(element, 'position') == 'relative') return element; element.style.position = 'relative'; var top = parseFloat(element.style.top || 0) - (element._originalTop || 0); var left = parseFloat(element.style.left || 0) - (element._originalLeft || 0); element.style.top = top + 'px'; element.style.left = left + 'px'; element.style.height = element._originalHeight; element.style.width = element._originalWidth; return element; }, cumulativeScrollOffset: function(element) { var valueT = 0, valueL = 0; do { valueT += element.scrollTop || 0; valueL += element.scrollLeft || 0; element = element.parentNode; } while (element); return Element._returnOffset(valueL, valueT); }, getOffsetParent: function(element) { if (element.offsetParent) return $(element.offsetParent); if (element == document.body) return $(element); while ((element = element.parentNode) && element != document.body) if (Element.getStyle(element, 'position') != 'static') return $(element); return $(document.body); }, viewportOffset: function(forElement) { var valueT = 0, valueL = 0; var element = forElement; do { valueT += element.offsetTop || 0; valueL += element.offsetLeft || 0; if (element.offsetParent == document.body && Element.getStyle(element, 'position') == 'absolute') break; } while (element = element.offsetParent); element = forElement; do { if (!Prototype.Browser.Opera || (element.tagName && (element.tagName.toUpperCase() == 'BODY'))) { valueT -= element.scrollTop || 0; valueL -= element.scrollLeft || 0; } } while (element = element.parentNode); return Element._returnOffset(valueL, valueT); }, clonePosition: function(element, source) { var options = Object.extend({ setLeft: true, setTop: true, setWidth: true, setHeight: true, offsetTop: 0, offsetLeft: 0 }, arguments[2] || { }); source = $(source); var p = Element.viewportOffset(source); element = $(element); var delta = [0, 0]; var parent = null; if (Element.getStyle(element, 'position') == 'absolute') { parent = Element.getOffsetParent(element); delta = Element.viewportOffset(parent); } if (parent == document.body) { delta[0] -= document.body.offsetLeft; delta[1] -= document.body.offsetTop; } if (options.setLeft) element.style.left = (p[0] - delta[0] + options.offsetLeft) + 'px'; if (options.setTop) element.style.top = (p[1] - delta[1] + options.offsetTop) + 'px'; if (options.setWidth) element.style.width = source.offsetWidth + 'px'; if (options.setHeight) element.style.height = source.offsetHeight + 'px'; return element; } }; Object.extend(Element.Methods, { getElementsBySelector: Element.Methods.select, childElements: Element.Methods.immediateDescendants }); Element._attributeTranslations = { write: { names: { className: 'class', htmlFor: 'for' }, values: { } } }; if (Prototype.Browser.Opera) { Element.Methods.getStyle = Element.Methods.getStyle.wrap( function(proceed, element, style) { switch (style) { case 'left': case 'top': case 'right': case 'bottom': if (proceed(element, 'position') === 'static') return null; case 'height': case 'width': if (!Element.visible(element)) return null; var dim = parseInt(proceed(element, style), 10); if (dim !== element['offset' + style.capitalize()]) return dim + 'px'; var properties; if (style === 'height') { properties = ['border-top-width', 'padding-top', 'padding-bottom', 'border-bottom-width']; } else { properties = ['border-left-width', 'padding-left', 'padding-right', 'border-right-width']; } return properties.inject(dim, function(memo, property) { var val = proceed(element, property); return val === null ? memo : memo - parseInt(val, 10); }) + 'px'; default: return proceed(element, style); } } ); Element.Methods.readAttribute = Element.Methods.readAttribute.wrap( function(proceed, element, attribute) { if (attribute === 'title') return element.title; return proceed(element, attribute); } ); } else if (Prototype.Browser.IE) { Element.Methods.getOffsetParent = Element.Methods.getOffsetParent.wrap( function(proceed, element) { element = $(element); try { element.offsetParent } catch(e) { return $(document.body) } var position = element.getStyle('position'); if (position !== 'static') return proceed(element); element.setStyle({ position: 'relative' }); var value = proceed(element); element.setStyle({ position: position }); return value; } ); $w('positionedOffset viewportOffset').each(function(method) { Element.Methods[method] = Element.Methods[method].wrap( function(proceed, element) { element = $(element); try { element.offsetParent } catch(e) { return Element._returnOffset(0,0) } var position = element.getStyle('position'); if (position !== 'static') return proceed(element); var offsetParent = element.getOffsetParent(); if (offsetParent && offsetParent.getStyle('position') === 'fixed') offsetParent.setStyle({ zoom: 1 }); element.setStyle({ position: 'relative' }); var value = proceed(element); element.setStyle({ position: position }); return value; } ); }); Element.Methods.cumulativeOffset = Element.Methods.cumulativeOffset.wrap( function(proceed, element) { try { element.offsetParent } catch(e) { return Element._returnOffset(0,0) } return proceed(element); } ); Element.Methods.getStyle = function(element, style) { element = $(element); style = (style == 'float' || style == 'cssFloat') ? 'styleFloat' : style.camelize(); var value = element.style[style]; if (!value && element.currentStyle) value = element.currentStyle[style]; if (style == 'opacity') { if (value = (element.getStyle('filter') || '').match(/alpha\(opacity=(.*)\)/)) if (value[1]) return parseFloat(value[1]) / 100; return 1.0; } if (value == 'auto') { if ((style == 'width' || style == 'height') && (element.getStyle('display') != 'none')) return element['offset' + style.capitalize()] + 'px'; return null; } return value; }; Element.Methods.setOpacity = function(element, value) { function stripAlpha(filter){ return filter.replace(/alpha\([^\)]*\)/gi,''); } element = $(element); var currentStyle = element.currentStyle; if ((currentStyle && !currentStyle.hasLayout) || (!currentStyle && element.style.zoom == 'normal')) element.style.zoom = 1; var filter = element.getStyle('filter'), style = element.style; if (value == 1 || value === '') { (filter = stripAlpha(filter)) ? style.filter = filter : style.removeAttribute('filter'); return element; } else if (value < 0.00001) value = 0; style.filter = stripAlpha(filter) + 'alpha(opacity=' + (value * 100) + ')'; return element; }; Element._attributeTranslations = (function(){ var classProp = 'className'; var forProp = 'for'; var el = document.createElement('div'); el.setAttribute(classProp, 'x'); if (el.className !== 'x') { el.setAttribute('class', 'x'); if (el.className === 'x') { classProp = 'class'; } } el = null; el = document.createElement('label'); el.setAttribute(forProp, 'x'); if (el.htmlFor !== 'x') { el.setAttribute('htmlFor', 'x'); if (el.htmlFor === 'x') { forProp = 'htmlFor'; } } el = null; return { read: { names: { 'class': classProp, 'className': classProp, 'for': forProp, 'htmlFor': forProp }, values: { _getAttr: function(element, attribute) { return element.getAttribute(attribute); }, _getAttr2: function(element, attribute) { return element.getAttribute(attribute, 2); }, _getAttrNode: function(element, attribute) { var node = element.getAttributeNode(attribute); return node ? node.value : ""; }, _getEv: (function(){ var el = document.createElement('div'); el.onclick = Prototype.emptyFunction; var value = el.getAttribute('onclick'); var f; if (String(value).indexOf('{') > -1) { f = function(element, attribute) { attribute = element.getAttribute(attribute); if (!attribute) return null; attribute = attribute.toString(); attribute = attribute.split('{')[1]; attribute = attribute.split('}')[0]; return attribute.strip(); }; } else if (value === '') { f = function(element, attribute) { attribute = element.getAttribute(attribute); if (!attribute) return null; return attribute.strip(); }; } el = null; return f; })(), _flag: function(element, attribute) { return $(element).hasAttribute(attribute) ? attribute : null; }, style: function(element) { return element.style.cssText.toLowerCase(); }, title: function(element) { return element.title; } } } } })(); Element._attributeTranslations.write = { names: Object.extend({ cellpadding: 'cellPadding', cellspacing: 'cellSpacing' }, Element._attributeTranslations.read.names), values: { checked: function(element, value) { element.checked = !!value; }, style: function(element, value) { element.style.cssText = value ? value : ''; } } }; Element._attributeTranslations.has = {}; $w('colSpan rowSpan vAlign dateTime accessKey tabIndex ' + 'encType maxLength readOnly longDesc frameBorder').each(function(attr) { Element._attributeTranslations.write.names[attr.toLowerCase()] = attr; Element._attributeTranslations.has[attr.toLowerCase()] = attr; }); (function(v) { Object.extend(v, { href: v._getAttr2, src: v._getAttr2, type: v._getAttr, action: v._getAttrNode, disabled: v._flag, checked: v._flag, readonly: v._flag, multiple: v._flag, onload: v._getEv, onunload: v._getEv, onclick: v._getEv, ondblclick: v._getEv, onmousedown: v._getEv, onmouseup: v._getEv, onmouseover: v._getEv, onmousemove: v._getEv, onmouseout: v._getEv, onfocus: v._getEv, onblur: v._getEv, onkeypress: v._getEv, onkeydown: v._getEv, onkeyup: v._getEv, onsubmit: v._getEv, onreset: v._getEv, onselect: v._getEv, onchange: v._getEv }); })(Element._attributeTranslations.read.values); if (Prototype.BrowserFeatures.ElementExtensions) { (function() { function _descendants(element) { var nodes = element.getElementsByTagName('*'), results = []; for (var i = 0, node; node = nodes[i]; i++) if (node.tagName !== "!") // Filter out comment nodes. results.push(node); return results; } Element.Methods.down = function(element, expression, index) { element = $(element); if (arguments.length == 1) return element.firstDescendant(); return Object.isNumber(expression) ? _descendants(element)[expression] : Element.select(element, expression)[index || 0]; } })(); } } else if (Prototype.Browser.Gecko && /rv:1\.8\.0/.test(navigator.userAgent)) { Element.Methods.setOpacity = function(element, value) { element = $(element); element.style.opacity = (value == 1) ? 0.999999 : (value === '') ? '' : (value < 0.00001) ? 0 : value; return element; }; } else if (Prototype.Browser.WebKit) { Element.Methods.setOpacity = function(element, value) { element = $(element); element.style.opacity = (value == 1 || value === '') ? '' : (value < 0.00001) ? 0 : value; if (value == 1) if(element.tagName.toUpperCase() == 'IMG' && element.width) { element.width++; element.width--; } else try { var n = document.createTextNode(' '); element.appendChild(n); element.removeChild(n); } catch (e) { } return element; }; Element.Methods.cumulativeOffset = function(element) { var valueT = 0, valueL = 0; do { valueT += element.offsetTop || 0; valueL += element.offsetLeft || 0; if (element.offsetParent == document.body) if (Element.getStyle(element, 'position') == 'absolute') break; element = element.offsetParent; } while (element); return Element._returnOffset(valueL, valueT); }; } if ('outerHTML' in document.documentElement) { Element.Methods.replace = function(element, content) { element = $(element); if (content && content.toElement) content = content.toElement(); if (Object.isElement(content)) { element.parentNode.replaceChild(content, element); return element; } content = Object.toHTML(content); var parent = element.parentNode, tagName = parent.tagName.toUpperCase(); if (Element._insertionTranslations.tags[tagName]) { var nextSibling = element.next(); var fragments = Element._getContentFromAnonymousElement(tagName, content.stripScripts()); parent.removeChild(element); if (nextSibling) fragments.each(function(node) { parent.insertBefore(node, nextSibling) }); else fragments.each(function(node) { parent.appendChild(node) }); } else element.outerHTML = content.stripScripts(); content.evalScripts.bind(content).defer(); return element; }; } Element._returnOffset = function(l, t) { var result = [l, t]; result.left = l; result.top = t; return result; }; Element._getContentFromAnonymousElement = function(tagName, html) { var div = new Element('div'), t = Element._insertionTranslations.tags[tagName]; if (t) { div.innerHTML = t[0] + html + t[1]; t[2].times(function() { div = div.firstChild }); } else div.innerHTML = html; return $A(div.childNodes); }; Element._insertionTranslations = { before: function(element, node) { element.parentNode.insertBefore(node, element); }, top: function(element, node) { element.insertBefore(node, element.firstChild); }, bottom: function(element, node) { element.appendChild(node); }, after: function(element, node) { element.parentNode.insertBefore(node, element.nextSibling); }, tags: { TABLE: ['', '
', 1], TBODY: ['', '
', 2], TR: ['', '
', 3], TD: ['
', '
', 4], SELECT: ['', 1] } }; (function() { var tags = Element._insertionTranslations.tags; Object.extend(tags, { THEAD: tags.TBODY, TFOOT: tags.TBODY, TH: tags.TD }); })(); Element.Methods.Simulated = { hasAttribute: function(element, attribute) { attribute = Element._attributeTranslations.has[attribute] || attribute; var node = $(element).getAttributeNode(attribute); return !!(node && node.specified); } }; Element.Methods.ByTag = { }; Object.extend(Element, Element.Methods); (function(div) { if (!Prototype.BrowserFeatures.ElementExtensions && div['__proto__']) { window.HTMLElement = { }; window.HTMLElement.prototype = div['__proto__']; Prototype.BrowserFeatures.ElementExtensions = true; } div = null; })(document.createElement('div')) Element.extend = (function() { function checkDeficiency(tagName) { if (typeof window.Element != 'undefined') { var proto = window.Element.prototype; if (proto) { var id = '_' + (Math.random()+'').slice(2); var el = document.createElement(tagName); proto[id] = 'x'; var isBuggy = (el[id] !== 'x'); delete proto[id]; el = null; return isBuggy; } } return false; } function extendElementWith(element, methods) { for (var property in methods) { var value = methods[property]; if (Object.isFunction(value) && !(property in element)) element[property] = value.methodize(); } } var HTMLOBJECTELEMENT_PROTOTYPE_BUGGY = checkDeficiency('object'); if (Prototype.BrowserFeatures.SpecificElementExtensions) { if (HTMLOBJECTELEMENT_PROTOTYPE_BUGGY) { return function(element) { if (element && typeof element._extendedByPrototype == 'undefined') { var t = element.tagName; if (t && (/^(?:object|applet|embed)$/i.test(t))) { extendElementWith(element, Element.Methods); extendElementWith(element, Element.Methods.Simulated); extendElementWith(element, Element.Methods.ByTag[t.toUpperCase()]); } } return element; } } return Prototype.K; } var Methods = { }, ByTag = Element.Methods.ByTag; var extend = Object.extend(function(element) { if (!element || typeof element._extendedByPrototype != 'undefined' || element.nodeType != 1 || element == window) return element; var methods = Object.clone(Methods), tagName = element.tagName.toUpperCase(); if (ByTag[tagName]) Object.extend(methods, ByTag[tagName]); extendElementWith(element, methods); element._extendedByPrototype = Prototype.emptyFunction; return element; }, { refresh: function() { if (!Prototype.BrowserFeatures.ElementExtensions) { Object.extend(Methods, Element.Methods); Object.extend(Methods, Element.Methods.Simulated); } } }); extend.refresh(); return extend; })(); Element.hasAttribute = function(element, attribute) { if (element.hasAttribute) return element.hasAttribute(attribute); return Element.Methods.Simulated.hasAttribute(element, attribute); }; Element.addMethods = function(methods) { var F = Prototype.BrowserFeatures, T = Element.Methods.ByTag; if (!methods) { Object.extend(Form, Form.Methods); Object.extend(Form.Element, Form.Element.Methods); Object.extend(Element.Methods.ByTag, { "FORM": Object.clone(Form.Methods), "INPUT": Object.clone(Form.Element.Methods), "SELECT": Object.clone(Form.Element.Methods), "TEXTAREA": Object.clone(Form.Element.Methods) }); } if (arguments.length == 2) { var tagName = methods; methods = arguments[1]; } if (!tagName) Object.extend(Element.Methods, methods || { }); else { if (Object.isArray(tagName)) tagName.each(extend); else extend(tagName); } function extend(tagName) { tagName = tagName.toUpperCase(); if (!Element.Methods.ByTag[tagName]) Element.Methods.ByTag[tagName] = { }; Object.extend(Element.Methods.ByTag[tagName], methods); } function copy(methods, destination, onlyIfAbsent) { onlyIfAbsent = onlyIfAbsent || false; for (var property in methods) { var value = methods[property]; if (!Object.isFunction(value)) continue; if (!onlyIfAbsent || !(property in destination)) destination[property] = value.methodize(); } } function findDOMClass(tagName) { var klass; var trans = { "OPTGROUP": "OptGroup", "TEXTAREA": "TextArea", "P": "Paragraph", "FIELDSET": "FieldSet", "UL": "UList", "OL": "OList", "DL": "DList", "DIR": "Directory", "H1": "Heading", "H2": "Heading", "H3": "Heading", "H4": "Heading", "H5": "Heading", "H6": "Heading", "Q": "Quote", "INS": "Mod", "DEL": "Mod", "A": "Anchor", "IMG": "Image", "CAPTION": "TableCaption", "COL": "TableCol", "COLGROUP": "TableCol", "THEAD": "TableSection", "TFOOT": "TableSection", "TBODY": "TableSection", "TR": "TableRow", "TH": "TableCell", "TD": "TableCell", "FRAMESET": "FrameSet", "IFRAME": "IFrame" }; if (trans[tagName]) klass = 'HTML' + trans[tagName] + 'Element'; if (window[klass]) return window[klass]; klass = 'HTML' + tagName + 'Element'; if (window[klass]) return window[klass]; klass = 'HTML' + tagName.capitalize() + 'Element'; if (window[klass]) return window[klass]; var element = document.createElement(tagName); var proto = element['__proto__'] || element.constructor.prototype; element = null; return proto; } var elementPrototype = window.HTMLElement ? HTMLElement.prototype : Element.prototype; if (F.ElementExtensions) { copy(Element.Methods, elementPrototype); copy(Element.Methods.Simulated, elementPrototype, true); } if (F.SpecificElementExtensions) { for (var tag in Element.Methods.ByTag) { var klass = findDOMClass(tag); if (Object.isUndefined(klass)) continue; copy(T[tag], klass.prototype); } } Object.extend(Element, Element.Methods); delete Element.ByTag; if (Element.extend.refresh) Element.extend.refresh(); Element.cache = { }; }; document.viewport = { getDimensions: function() { return { width: this.getWidth(), height: this.getHeight() }; }, getScrollOffsets: function() { return Element._returnOffset( window.pageXOffset || document.documentElement.scrollLeft || document.body.scrollLeft, window.pageYOffset || document.documentElement.scrollTop || document.body.scrollTop); } }; (function(viewport) { var B = Prototype.Browser, doc = document, element, property = {}; function getRootElement() { if (B.WebKit && !doc.evaluate) return document; if (B.Opera && window.parseFloat(window.opera.version()) < 9.5) return document.body; return document.documentElement; } function define(D) { if (!element) element = getRootElement(); property[D] = 'client' + D; viewport['get' + D] = function() { return element[property[D]] }; return viewport['get' + D](); } viewport.getWidth = define.curry('Width'); viewport.getHeight = define.curry('Height'); })(document.viewport); Element.Storage = { UID: 1 }; Element.addMethods({ getStorage: function(element) { if (!(element = $(element))) return; var uid; if (element === window) { uid = 0; } else { if (typeof element._prototypeUID === "undefined") element._prototypeUID = [Element.Storage.UID++]; uid = element._prototypeUID[0]; } if (!Element.Storage[uid]) Element.Storage[uid] = $H(); return Element.Storage[uid]; }, store: function(element, key, value) { if (!(element = $(element))) return; if (arguments.length === 2) { Element.getStorage(element).update(key); } else { Element.getStorage(element).set(key, value); } return element; }, retrieve: function(element, key, defaultValue) { if (!(element = $(element))) return; var hash = Element.getStorage(element), value = hash.get(key); if (Object.isUndefined(value)) { hash.set(key, defaultValue); value = defaultValue; } return value; }, clone: function(element, deep) { if (!(element = $(element))) return; var clone = element.cloneNode(deep); clone._prototypeUID = void 0; if (deep) { var descendants = Element.select(clone, '*'), i = descendants.length; while (i--) { descendants[i]._prototypeUID = void 0; } } return Element.extend(clone); } }); /* Portions of the Selector class are derived from Jack Slocum's DomQuery, * part of YUI-Ext version 0.40, distributed under the terms of an MIT-style * license. Please see http://www.yui-ext.com/ for more information. */ var Selector = Class.create({ initialize: function(expression) { this.expression = expression.strip(); if (this.shouldUseSelectorsAPI()) { this.mode = 'selectorsAPI'; } else if (this.shouldUseXPath()) { this.mode = 'xpath'; this.compileXPathMatcher(); } else { this.mode = "normal"; this.compileMatcher(); } }, shouldUseXPath: (function() { var IS_DESCENDANT_SELECTOR_BUGGY = (function(){ var isBuggy = false; if (document.evaluate && window.XPathResult) { var el = document.createElement('div'); el.innerHTML = '
'; var xpath = ".//*[local-name()='ul' or local-name()='UL']" + "//*[local-name()='li' or local-name()='LI']"; var result = document.evaluate(xpath, el, null, XPathResult.ORDERED_NODE_SNAPSHOT_TYPE, null); isBuggy = (result.snapshotLength !== 2); el = null; } return isBuggy; })(); return function() { if (!Prototype.BrowserFeatures.XPath) return false; var e = this.expression; if (Prototype.Browser.WebKit && (e.include("-of-type") || e.include(":empty"))) return false; if ((/(\[[\w-]*?:|:checked)/).test(e)) return false; if (IS_DESCENDANT_SELECTOR_BUGGY) return false; return true; } })(), shouldUseSelectorsAPI: function() { if (!Prototype.BrowserFeatures.SelectorsAPI) return false; if (Selector.CASE_INSENSITIVE_CLASS_NAMES) return false; if (!Selector._div) Selector._div = new Element('div'); try { Selector._div.querySelector(this.expression); } catch(e) { return false; } return true; }, compileMatcher: function() { var e = this.expression, ps = Selector.patterns, h = Selector.handlers, c = Selector.criteria, le, p, m, len = ps.length, name; if (Selector._cache[e]) { this.matcher = Selector._cache[e]; return; } this.matcher = ["this.matcher = function(root) {", "var r = root, h = Selector.handlers, c = false, n;"]; while (e && le != e && (/\S/).test(e)) { le = e; for (var i = 0; i"; } }); if (Prototype.BrowserFeatures.SelectorsAPI && document.compatMode === 'BackCompat') { Selector.CASE_INSENSITIVE_CLASS_NAMES = (function(){ var div = document.createElement('div'), span = document.createElement('span'); div.id = "prototype_test_id"; span.className = 'Test'; div.appendChild(span); var isIgnored = (div.querySelector('#prototype_test_id .test') !== null); div = span = null; return isIgnored; })(); } Object.extend(Selector, { _cache: { }, xpath: { descendant: "//*", child: "/*", adjacent: "/following-sibling::*[1]", laterSibling: '/following-sibling::*', tagName: function(m) { if (m[1] == '*') return ''; return "[local-name()='" + m[1].toLowerCase() + "' or local-name()='" + m[1].toUpperCase() + "']"; }, className: "[contains(concat(' ', @class, ' '), ' #{1} ')]", id: "[@id='#{1}']", attrPresence: function(m) { m[1] = m[1].toLowerCase(); return new Template("[@#{1}]").evaluate(m); }, attr: function(m) { m[1] = m[1].toLowerCase(); m[3] = m[5] || m[6]; return new Template(Selector.xpath.operators[m[2]]).evaluate(m); }, pseudo: function(m) { var h = Selector.xpath.pseudos[m[1]]; if (!h) return ''; if (Object.isFunction(h)) return h(m); return new Template(Selector.xpath.pseudos[m[1]]).evaluate(m); }, operators: { '=': "[@#{1}='#{3}']", '!=': "[@#{1}!='#{3}']", '^=': "[starts-with(@#{1}, '#{3}')]", '$=': "[substring(@#{1}, (string-length(@#{1}) - string-length('#{3}') + 1))='#{3}']", '*=': "[contains(@#{1}, '#{3}')]", '~=': "[contains(concat(' ', @#{1}, ' '), ' #{3} ')]", '|=': "[contains(concat('-', @#{1}, '-'), '-#{3}-')]" }, pseudos: { 'first-child': '[not(preceding-sibling::*)]', 'last-child': '[not(following-sibling::*)]', 'only-child': '[not(preceding-sibling::* or following-sibling::*)]', 'empty': "[count(*) = 0 and (count(text()) = 0)]", 'checked': "[@checked]", 'disabled': "[(@disabled) and (@type!='hidden')]", 'enabled': "[not(@disabled) and (@type!='hidden')]", 'not': function(m) { var e = m[6], p = Selector.patterns, x = Selector.xpath, le, v, len = p.length, name; var exclusion = []; while (e && le != e && (/\S/).test(e)) { le = e; for (var i = 0; i= 0)]"; return new Template(predicate).evaluate({ fragment: fragment, a: a, b: b }); } } } }, criteria: { tagName: 'n = h.tagName(n, r, "#{1}", c); c = false;', className: 'n = h.className(n, r, "#{1}", c); c = false;', id: 'n = h.id(n, r, "#{1}", c); c = false;', attrPresence: 'n = h.attrPresence(n, r, "#{1}", c); c = false;', attr: function(m) { m[3] = (m[5] || m[6]); return new Template('n = h.attr(n, r, "#{1}", "#{3}", "#{2}", c); c = false;').evaluate(m); }, pseudo: function(m) { if (m[6]) m[6] = m[6].replace(/"/g, '\\"'); return new Template('n = h.pseudo(n, "#{1}", "#{6}", r, c); c = false;').evaluate(m); }, descendant: 'c = "descendant";', child: 'c = "child";', adjacent: 'c = "adjacent";', laterSibling: 'c = "laterSibling";' }, patterns: [ { name: 'laterSibling', re: /^\s*~\s*/ }, { name: 'child', re: /^\s*>\s*/ }, { name: 'adjacent', re: /^\s*\+\s*/ }, { name: 'descendant', re: /^\s/ }, { name: 'tagName', re: /^\s*(\*|[\w\-]+)(\b|$)?/ }, { name: 'id', re: /^#([\w\-\*]+)(\b|$)/ }, { name: 'className', re: /^\.([\w\-\*]+)(\b|$)/ }, { name: 'pseudo', re: /^:((first|last|nth|nth-last|only)(-child|-of-type)|empty|checked|(en|dis)abled|not)(\((.*?)\))?(\b|$|(?=\s|[:+~>]))/ }, { name: 'attrPresence', re: /^\[((?:[\w-]+:)?[\w-]+)\]/ }, { name: 'attr', re: /\[((?:[\w-]*:)?[\w-]+)\s*(?:([!^$*~|]?=)\s*((['"])([^\4]*?)\4|([^'"][^\]]*?)))?\]/ } ], assertions: { tagName: function(element, matches) { return matches[1].toUpperCase() == element.tagName.toUpperCase(); }, className: function(element, matches) { return Element.hasClassName(element, matches[1]); }, id: function(element, matches) { return element.id === matches[1]; }, attrPresence: function(element, matches) { return Element.hasAttribute(element, matches[1]); }, attr: function(element, matches) { var nodeValue = Element.readAttribute(element, matches[1]); return nodeValue && Selector.operators[matches[2]](nodeValue, matches[5] || matches[6]); } }, handlers: { concat: function(a, b) { for (var i = 0, node; node = b[i]; i++) a.push(node); return a; }, mark: function(nodes) { var _true = Prototype.emptyFunction; for (var i = 0, node; node = nodes[i]; i++) node._countedByPrototype = _true; return nodes; }, unmark: (function(){ var PROPERTIES_ATTRIBUTES_MAP = (function(){ var el = document.createElement('div'), isBuggy = false, propName = '_countedByPrototype', value = 'x' el[propName] = value; isBuggy = (el.getAttribute(propName) === value); el = null; return isBuggy; })(); return PROPERTIES_ATTRIBUTES_MAP ? function(nodes) { for (var i = 0, node; node = nodes[i]; i++) node.removeAttribute('_countedByPrototype'); return nodes; } : function(nodes) { for (var i = 0, node; node = nodes[i]; i++) node._countedByPrototype = void 0; return nodes; } })(), index: function(parentNode, reverse, ofType) { parentNode._countedByPrototype = Prototype.emptyFunction; if (reverse) { for (var nodes = parentNode.childNodes, i = nodes.length - 1, j = 1; i >= 0; i--) { var node = nodes[i]; if (node.nodeType == 1 && (!ofType || node._countedByPrototype)) node.nodeIndex = j++; } } else { for (var i = 0, j = 1, nodes = parentNode.childNodes; node = nodes[i]; i++) if (node.nodeType == 1 && (!ofType || node._countedByPrototype)) node.nodeIndex = j++; } }, unique: function(nodes) { if (nodes.length == 0) return nodes; var results = [], n; for (var i = 0, l = nodes.length; i < l; i++) if (typeof (n = nodes[i])._countedByPrototype == 'undefined') { n._countedByPrototype = Prototype.emptyFunction; results.push(Element.extend(n)); } return Selector.handlers.unmark(results); }, descendant: function(nodes) { var h = Selector.handlers; for (var i = 0, results = [], node; node = nodes[i]; i++) h.concat(results, node.getElementsByTagName('*')); return results; }, child: function(nodes) { var h = Selector.handlers; for (var i = 0, results = [], node; node = nodes[i]; i++) { for (var j = 0, child; child = node.childNodes[j]; j++) if (child.nodeType == 1 && child.tagName != '!') results.push(child); } return results; }, adjacent: function(nodes) { for (var i = 0, results = [], node; node = nodes[i]; i++) { var next = this.nextElementSibling(node); if (next) results.push(next); } return results; }, laterSibling: function(nodes) { var h = Selector.handlers; for (var i = 0, results = [], node; node = nodes[i]; i++) h.concat(results, Element.nextSiblings(node)); return results; }, nextElementSibling: function(node) { while (node = node.nextSibling) if (node.nodeType == 1) return node; return null; }, previousElementSibling: function(node) { while (node = node.previousSibling) if (node.nodeType == 1) return node; return null; }, tagName: function(nodes, root, tagName, combinator) { var uTagName = tagName.toUpperCase(); var results = [], h = Selector.handlers; if (nodes) { if (combinator) { if (combinator == "descendant") { for (var i = 0, node; node = nodes[i]; i++) h.concat(results, node.getElementsByTagName(tagName)); return results; } else nodes = this[combinator](nodes); if (tagName == "*") return nodes; } for (var i = 0, node; node = nodes[i]; i++) if (node.tagName.toUpperCase() === uTagName) results.push(node); return results; } else return root.getElementsByTagName(tagName); }, id: function(nodes, root, id, combinator) { var targetNode = $(id), h = Selector.handlers; if (root == document) { if (!targetNode) return []; if (!nodes) return [targetNode]; } else { if (!root.sourceIndex || root.sourceIndex < 1) { var nodes = root.getElementsByTagName('*'); for (var j = 0, node; node = nodes[j]; j++) { if (node.id === id) return [node]; } } } if (nodes) { if (combinator) { if (combinator == 'child') { for (var i = 0, node; node = nodes[i]; i++) if (targetNode.parentNode == node) return [targetNode]; } else if (combinator == 'descendant') { for (var i = 0, node; node = nodes[i]; i++) if (Element.descendantOf(targetNode, node)) return [targetNode]; } else if (combinator == 'adjacent') { for (var i = 0, node; node = nodes[i]; i++) if (Selector.handlers.previousElementSibling(targetNode) == node) return [targetNode]; } else nodes = h[combinator](nodes); } for (var i = 0, node; node = nodes[i]; i++) if (node == targetNode) return [targetNode]; return []; } return (targetNode && Element.descendantOf(targetNode, root)) ? [targetNode] : []; }, className: function(nodes, root, className, combinator) { if (nodes && combinator) nodes = this[combinator](nodes); return Selector.handlers.byClassName(nodes, root, className); }, byClassName: function(nodes, root, className) { if (!nodes) nodes = Selector.handlers.descendant([root]); var needle = ' ' + className + ' '; for (var i = 0, results = [], node, nodeClassName; node = nodes[i]; i++) { nodeClassName = node.className; if (nodeClassName.length == 0) continue; if (nodeClassName == className || (' ' + nodeClassName + ' ').include(needle)) results.push(node); } return results; }, attrPresence: function(nodes, root, attr, combinator) { if (!nodes) nodes = root.getElementsByTagName("*"); if (nodes && combinator) nodes = this[combinator](nodes); var results = []; for (var i = 0, node; node = nodes[i]; i++) if (Element.hasAttribute(node, attr)) results.push(node); return results; }, attr: function(nodes, root, attr, value, operator, combinator) { if (!nodes) nodes = root.getElementsByTagName("*"); if (nodes && combinator) nodes = this[combinator](nodes); var handler = Selector.operators[operator], results = []; for (var i = 0, node; node = nodes[i]; i++) { var nodeValue = Element.readAttribute(node, attr); if (nodeValue === null) continue; if (handler(nodeValue, value)) results.push(node); } return results; }, pseudo: function(nodes, name, value, root, combinator) { if (nodes && combinator) nodes = this[combinator](nodes); if (!nodes) nodes = root.getElementsByTagName("*"); return Selector.pseudos[name](nodes, value, root); } }, pseudos: { 'first-child': function(nodes, value, root) { for (var i = 0, results = [], node; node = nodes[i]; i++) { if (Selector.handlers.previousElementSibling(node)) continue; results.push(node); } return results; }, 'last-child': function(nodes, value, root) { for (var i = 0, results = [], node; node = nodes[i]; i++) { if (Selector.handlers.nextElementSibling(node)) continue; results.push(node); } return results; }, 'only-child': function(nodes, value, root) { var h = Selector.handlers; for (var i = 0, results = [], node; node = nodes[i]; i++) if (!h.previousElementSibling(node) && !h.nextElementSibling(node)) results.push(node); return results; }, 'nth-child': function(nodes, formula, root) { return Selector.pseudos.nth(nodes, formula, root); }, 'nth-last-child': function(nodes, formula, root) { return Selector.pseudos.nth(nodes, formula, root, true); }, 'nth-of-type': function(nodes, formula, root) { return Selector.pseudos.nth(nodes, formula, root, false, true); }, 'nth-last-of-type': function(nodes, formula, root) { return Selector.pseudos.nth(nodes, formula, root, true, true); }, 'first-of-type': function(nodes, formula, root) { return Selector.pseudos.nth(nodes, "1", root, false, true); }, 'last-of-type': function(nodes, formula, root) { return Selector.pseudos.nth(nodes, "1", root, true, true); }, 'only-of-type': function(nodes, formula, root) { var p = Selector.pseudos; return p['last-of-type'](p['first-of-type'](nodes, formula, root), formula, root); }, getIndices: function(a, b, total) { if (a == 0) return b > 0 ? [b] : []; return $R(1, total).inject([], function(memo, i) { if (0 == (i - b) % a && (i - b) / a >= 0) memo.push(i); return memo; }); }, nth: function(nodes, formula, root, reverse, ofType) { if (nodes.length == 0) return []; if (formula == 'even') formula = '2n+0'; if (formula == 'odd') formula = '2n+1'; var h = Selector.handlers, results = [], indexed = [], m; h.mark(nodes); for (var i = 0, node; node = nodes[i]; i++) { if (!node.parentNode._countedByPrototype) { h.index(node.parentNode, reverse, ofType); indexed.push(node.parentNode); } } if (formula.match(/^\d+$/)) { // just a number formula = Number(formula); for (var i = 0, node; node = nodes[i]; i++) if (node.nodeIndex == formula) results.push(node); } else if (m = formula.match(/^(-?\d*)?n(([+-])(\d+))?/)) { // an+b if (m[1] == "-") m[1] = -1; var a = m[1] ? Number(m[1]) : 1; var b = m[2] ? Number(m[2]) : 0; var indices = Selector.pseudos.getIndices(a, b, nodes.length); for (var i = 0, node, l = indices.length; node = nodes[i]; i++) { for (var j = 0; j < l; j++) if (node.nodeIndex == indices[j]) results.push(node); } } h.unmark(nodes); h.unmark(indexed); return results; }, 'empty': function(nodes, value, root) { for (var i = 0, results = [], node; node = nodes[i]; i++) { if (node.tagName == '!' || node.firstChild) continue; results.push(node); } return results; }, 'not': function(nodes, selector, root) { var h = Selector.handlers, selectorType, m; var exclusions = new Selector(selector).findElements(root); h.mark(exclusions); for (var i = 0, results = [], node; node = nodes[i]; i++) if (!node._countedByPrototype) results.push(node); h.unmark(exclusions); return results; }, 'enabled': function(nodes, value, root) { for (var i = 0, results = [], node; node = nodes[i]; i++) if (!node.disabled && (!node.type || node.type !== 'hidden')) results.push(node); return results; }, 'disabled': function(nodes, value, root) { for (var i = 0, results = [], node; node = nodes[i]; i++) if (node.disabled) results.push(node); return results; }, 'checked': function(nodes, value, root) { for (var i = 0, results = [], node; node = nodes[i]; i++) if (node.checked) results.push(node); return results; } }, operators: { '=': function(nv, v) { return nv == v; }, '!=': function(nv, v) { return nv != v; }, '^=': function(nv, v) { return nv == v || nv && nv.startsWith(v); }, '$=': function(nv, v) { return nv == v || nv && nv.endsWith(v); }, '*=': function(nv, v) { return nv == v || nv && nv.include(v); }, '~=': function(nv, v) { return (' ' + nv + ' ').include(' ' + v + ' '); }, '|=': function(nv, v) { return ('-' + (nv || "").toUpperCase() + '-').include('-' + (v || "").toUpperCase() + '-'); } }, split: function(expression) { var expressions = []; expression.scan(/(([\w#:.~>+()\s-]+|\*|\[.*?\])+)\s*(,|$)/, function(m) { expressions.push(m[1].strip()); }); return expressions; }, matchElements: function(elements, expression) { var matches = $$(expression), h = Selector.handlers; h.mark(matches); for (var i = 0, results = [], element; element = elements[i]; i++) if (element._countedByPrototype) results.push(element); h.unmark(matches); return results; }, findElement: function(elements, expression, index) { if (Object.isNumber(expression)) { index = expression; expression = false; } return Selector.matchElements(elements, expression || '*')[index || 0]; }, findChildElements: function(element, expressions) { expressions = Selector.split(expressions.join(',')); var results = [], h = Selector.handlers; for (var i = 0, l = expressions.length, selector; i < l; i++) { selector = new Selector(expressions[i].strip()); h.concat(results, selector.findElements(element)); } return (l > 1) ? h.unique(results) : results; } }); if (Prototype.Browser.IE) { Object.extend(Selector.handlers, { concat: function(a, b) { for (var i = 0, node; node = b[i]; i++) if (node.tagName !== "!") a.push(node); return a; } }); } function $$() { return Selector.findChildElements(document, $A(arguments)); } var Form = { reset: function(form) { form = $(form); form.reset(); return form; }, serializeElements: function(elements, options) { if (typeof options != 'object') options = { hash: !!options }; else if (Object.isUndefined(options.hash)) options.hash = true; var key, value, submitted = false, submit = options.submit; var data = elements.inject({ }, function(result, element) { if (!element.disabled && element.name) { key = element.name; value = $(element).getValue(); if (value != null && element.type != 'file' && (element.type != 'submit' || (!submitted && submit !== false && (!submit || key == submit) && (submitted = true)))) { if (key in result) { if (!Object.isArray(result[key])) result[key] = [result[key]]; result[key].push(value); } else result[key] = value; } } return result; }); return options.hash ? data : Object.toQueryString(data); } }; Form.Methods = { serialize: function(form, options) { return Form.serializeElements(Form.getElements(form), options); }, getElements: function(form) { var elements = $(form).getElementsByTagName('*'), element, arr = [ ], serializers = Form.Element.Serializers; for (var i = 0; element = elements[i]; i++) { arr.push(element); } return arr.inject([], function(elements, child) { if (serializers[child.tagName.toLowerCase()]) elements.push(Element.extend(child)); return elements; }) }, getInputs: function(form, typeName, name) { form = $(form); var inputs = form.getElementsByTagName('input'); if (!typeName && !name) return $A(inputs).map(Element.extend); for (var i = 0, matchingInputs = [], length = inputs.length; i < length; i++) { var input = inputs[i]; if ((typeName && input.type != typeName) || (name && input.name != name)) continue; matchingInputs.push(Element.extend(input)); } return matchingInputs; }, disable: function(form) { form = $(form); Form.getElements(form).invoke('disable'); return form; }, enable: function(form) { form = $(form); Form.getElements(form).invoke('enable'); return form; }, findFirstElement: function(form) { var elements = $(form).getElements().findAll(function(element) { return 'hidden' != element.type && !element.disabled; }); var firstByIndex = elements.findAll(function(element) { return element.hasAttribute('tabIndex') && element.tabIndex >= 0; }).sortBy(function(element) { return element.tabIndex }).first(); return firstByIndex ? firstByIndex : elements.find(function(element) { return /^(?:input|select|textarea)$/i.test(element.tagName); }); }, focusFirstElement: function(form) { form = $(form); form.findFirstElement().activate(); return form; }, request: function(form, options) { form = $(form), options = Object.clone(options || { }); var params = options.parameters, action = form.readAttribute('action') || ''; if (action.blank()) action = window.location.href; options.parameters = form.serialize(true); if (params) { if (Object.isString(params)) params = params.toQueryParams(); Object.extend(options.parameters, params); } if (form.hasAttribute('method') && !options.method) options.method = form.method; return new Ajax.Request(action, options); } }; /*--------------------------------------------------------------------------*/ Form.Element = { focus: function(element) { $(element).focus(); return element; }, select: function(element) { $(element).select(); return element; } }; Form.Element.Methods = { serialize: function(element) { element = $(element); if (!element.disabled && element.name) { var value = element.getValue(); if (value != undefined) { var pair = { }; pair[element.name] = value; return Object.toQueryString(pair); } } return ''; }, getValue: function(element) { element = $(element); var method = element.tagName.toLowerCase(); return Form.Element.Serializers[method](element); }, setValue: function(element, value) { element = $(element); var method = element.tagName.toLowerCase(); Form.Element.Serializers[method](element, value); return element; }, clear: function(element) { $(element).value = ''; return element; }, present: function(element) { return $(element).value != ''; }, activate: function(element) { element = $(element); try { element.focus(); if (element.select && (element.tagName.toLowerCase() != 'input' || !(/^(?:button|reset|submit)$/i.test(element.type)))) element.select(); } catch (e) { } return element; }, disable: function(element) { element = $(element); element.disabled = true; return element; }, enable: function(element) { element = $(element); element.disabled = false; return element; } }; /*--------------------------------------------------------------------------*/ var Field = Form.Element; var $F = Form.Element.Methods.getValue; /*--------------------------------------------------------------------------*/ Form.Element.Serializers = { input: function(element, value) { switch (element.type.toLowerCase()) { case 'checkbox': case 'radio': return Form.Element.Serializers.inputSelector(element, value); default: return Form.Element.Serializers.textarea(element, value); } }, inputSelector: function(element, value) { if (Object.isUndefined(value)) return element.checked ? element.value : null; else element.checked = !!value; }, textarea: function(element, value) { if (Object.isUndefined(value)) return element.value; else element.value = value; }, select: function(element, value) { if (Object.isUndefined(value)) return this[element.type == 'select-one' ? 'selectOne' : 'selectMany'](element); else { var opt, currentValue, single = !Object.isArray(value); for (var i = 0, length = element.length; i < length; i++) { opt = element.options[i]; currentValue = this.optionValue(opt); if (single) { if (currentValue == value) { opt.selected = true; return; } } else opt.selected = value.include(currentValue); } } }, selectOne: function(element) { var index = element.selectedIndex; return index >= 0 ? this.optionValue(element.options[index]) : null; }, selectMany: function(element) { var values, length = element.length; if (!length) return null; for (var i = 0, values = []; i < length; i++) { var opt = element.options[i]; if (opt.selected) values.push(this.optionValue(opt)); } return values; }, optionValue: function(opt) { return Element.extend(opt).hasAttribute('value') ? opt.value : opt.text; } }; /*--------------------------------------------------------------------------*/ Abstract.TimedObserver = Class.create(PeriodicalExecuter, { initialize: function($super, element, frequency, callback) { $super(callback, frequency); this.element = $(element); this.lastValue = this.getValue(); }, execute: function() { var value = this.getValue(); if (Object.isString(this.lastValue) && Object.isString(value) ? this.lastValue != value : String(this.lastValue) != String(value)) { this.callback(this.element, value); this.lastValue = value; } } }); Form.Element.Observer = Class.create(Abstract.TimedObserver, { getValue: function() { return Form.Element.getValue(this.element); } }); Form.Observer = Class.create(Abstract.TimedObserver, { getValue: function() { return Form.serialize(this.element); } }); /*--------------------------------------------------------------------------*/ Abstract.EventObserver = Class.create({ initialize: function(element, callback) { this.element = $(element); this.callback = callback; this.lastValue = this.getValue(); if (this.element.tagName.toLowerCase() == 'form') this.registerFormCallbacks(); else this.registerCallback(this.element); }, onElementEvent: function() { var value = this.getValue(); if (this.lastValue != value) { this.callback(this.element, value); this.lastValue = value; } }, registerFormCallbacks: function() { Form.getElements(this.element).each(this.registerCallback, this); }, registerCallback: function(element) { if (element.type) { switch (element.type.toLowerCase()) { case 'checkbox': case 'radio': Event.observe(element, 'click', this.onElementEvent.bind(this)); break; default: Event.observe(element, 'change', this.onElementEvent.bind(this)); break; } } } }); Form.Element.EventObserver = Class.create(Abstract.EventObserver, { getValue: function() { return Form.Element.getValue(this.element); } }); Form.EventObserver = Class.create(Abstract.EventObserver, { getValue: function() { return Form.serialize(this.element); } }); (function() { var Event = { KEY_BACKSPACE: 8, KEY_TAB: 9, KEY_RETURN: 13, KEY_ESC: 27, KEY_LEFT: 37, KEY_UP: 38, KEY_RIGHT: 39, KEY_DOWN: 40, KEY_DELETE: 46, KEY_HOME: 36, KEY_END: 35, KEY_PAGEUP: 33, KEY_PAGEDOWN: 34, KEY_INSERT: 45, cache: {} }; var docEl = document.documentElement; var MOUSEENTER_MOUSELEAVE_EVENTS_SUPPORTED = 'onmouseenter' in docEl && 'onmouseleave' in docEl; var _isButton; if (Prototype.Browser.IE) { var buttonMap = { 0: 1, 1: 4, 2: 2 }; _isButton = function(event, code) { return event.button === buttonMap[code]; }; } else if (Prototype.Browser.WebKit) { _isButton = function(event, code) { switch (code) { case 0: return event.which == 1 && !event.metaKey; case 1: return event.which == 1 && event.metaKey; default: return false; } }; } else { _isButton = function(event, code) { return event.which ? (event.which === code + 1) : (event.button === code); }; } function isLeftClick(event) { return _isButton(event, 0) } function isMiddleClick(event) { return _isButton(event, 1) } function isRightClick(event) { return _isButton(event, 2) } function element(event) { event = Event.extend(event); var node = event.target, type = event.type, currentTarget = event.currentTarget; if (currentTarget && currentTarget.tagName) { if (type === 'load' || type === 'error' || (type === 'click' && currentTarget.tagName.toLowerCase() === 'input' && currentTarget.type === 'radio')) node = currentTarget; } if (node.nodeType == Node.TEXT_NODE) node = node.parentNode; return Element.extend(node); } function findElement(event, expression) { var element = Event.element(event); if (!expression) return element; var elements = [element].concat(element.ancestors()); return Selector.findElement(elements, expression, 0); } function pointer(event) { return { x: pointerX(event), y: pointerY(event) }; } function pointerX(event) { var docElement = document.documentElement, body = document.body || { scrollLeft: 0 }; return event.pageX || (event.clientX + (docElement.scrollLeft || body.scrollLeft) - (docElement.clientLeft || 0)); } function pointerY(event) { var docElement = document.documentElement, body = document.body || { scrollTop: 0 }; return event.pageY || (event.clientY + (docElement.scrollTop || body.scrollTop) - (docElement.clientTop || 0)); } function stop(event) { Event.extend(event); event.preventDefault(); event.stopPropagation(); event.stopped = true; } Event.Methods = { isLeftClick: isLeftClick, isMiddleClick: isMiddleClick, isRightClick: isRightClick, element: element, findElement: findElement, pointer: pointer, pointerX: pointerX, pointerY: pointerY, stop: stop }; var methods = Object.keys(Event.Methods).inject({ }, function(m, name) { m[name] = Event.Methods[name].methodize(); return m; }); if (Prototype.Browser.IE) { function _relatedTarget(event) { var element; switch (event.type) { case 'mouseover': element = event.fromElement; break; case 'mouseout': element = event.toElement; break; default: return null; } return Element.extend(element); } Object.extend(methods, { stopPropagation: function() { this.cancelBubble = true }, preventDefault: function() { this.returnValue = false }, inspect: function() { return '[object Event]' } }); Event.extend = function(event, element) { if (!event) return false; if (event._extendedByPrototype) return event; event._extendedByPrototype = Prototype.emptyFunction; var pointer = Event.pointer(event); Object.extend(event, { target: event.srcElement || element, relatedTarget: _relatedTarget(event), pageX: pointer.x, pageY: pointer.y }); return Object.extend(event, methods); }; } else { Event.prototype = window.Event.prototype || document.createEvent('HTMLEvents').__proto__; Object.extend(Event.prototype, methods); Event.extend = Prototype.K; } function _createResponder(element, eventName, handler) { var registry = Element.retrieve(element, 'prototype_event_registry'); if (Object.isUndefined(registry)) { CACHE.push(element); registry = Element.retrieve(element, 'prototype_event_registry', $H()); } var respondersForEvent = registry.get(eventName); if (Object.isUndefined(respondersForEvent)) { respondersForEvent = []; registry.set(eventName, respondersForEvent); } if (respondersForEvent.pluck('handler').include(handler)) return false; var responder; if (eventName.include(":")) { responder = function(event) { if (Object.isUndefined(event.eventName)) return false; if (event.eventName !== eventName) return false; Event.extend(event, element); handler.call(element, event); }; } else { if (!MOUSEENTER_MOUSELEAVE_EVENTS_SUPPORTED && (eventName === "mouseenter" || eventName === "mouseleave")) { if (eventName === "mouseenter" || eventName === "mouseleave") { responder = function(event) { Event.extend(event, element); var parent = event.relatedTarget; while (parent && parent !== element) { try { parent = parent.parentNode; } catch(e) { parent = element; } } if (parent === element) return; handler.call(element, event); }; } } else { responder = function(event) { Event.extend(event, element); handler.call(element, event); }; } } responder.handler = handler; respondersForEvent.push(responder); return responder; } function _destroyCache() { for (var i = 0, length = CACHE.length; i < length; i++) { Event.stopObserving(CACHE[i]); CACHE[i] = null; } } var CACHE = []; if (Prototype.Browser.IE) window.attachEvent('onunload', _destroyCache); if (Prototype.Browser.WebKit) window.addEventListener('unload', Prototype.emptyFunction, false); var _getDOMEventName = Prototype.K; if (!MOUSEENTER_MOUSELEAVE_EVENTS_SUPPORTED) { _getDOMEventName = function(eventName) { var translations = { mouseenter: "mouseover", mouseleave: "mouseout" }; return eventName in translations ? translations[eventName] : eventName; }; } function observe(element, eventName, handler) { element = $(element); var responder = _createResponder(element, eventName, handler); if (!responder) return element; if (eventName.include(':')) { if (element.addEventListener) element.addEventListener("dataavailable", responder, false); else { element.attachEvent("ondataavailable", responder); element.attachEvent("onfilterchange", responder); } } else { var actualEventName = _getDOMEventName(eventName); if (element.addEventListener) element.addEventListener(actualEventName, responder, false); else element.attachEvent("on" + actualEventName, responder); } return element; } function stopObserving(element, eventName, handler) { element = $(element); var registry = Element.retrieve(element, 'prototype_event_registry'); if (Object.isUndefined(registry)) return element; if (eventName && !handler) { var responders = registry.get(eventName); if (Object.isUndefined(responders)) return element; responders.each( function(r) { Element.stopObserving(element, eventName, r.handler); }); return element; } else if (!eventName) { registry.each( function(pair) { var eventName = pair.key, responders = pair.value; responders.each( function(r) { Element.stopObserving(element, eventName, r.handler); }); }); return element; } var responders = registry.get(eventName); if (!responders) return; var responder = responders.find( function(r) { return r.handler === handler; }); if (!responder) return element; var actualEventName = _getDOMEventName(eventName); if (eventName.include(':')) { if (element.removeEventListener) element.removeEventListener("dataavailable", responder, false); else { element.detachEvent("ondataavailable", responder); element.detachEvent("onfilterchange", responder); } } else { if (element.removeEventListener) element.removeEventListener(actualEventName, responder, false); else element.detachEvent('on' + actualEventName, responder); } registry.set(eventName, responders.without(responder)); return element; } function fire(element, eventName, memo, bubble) { element = $(element); if (Object.isUndefined(bubble)) bubble = true; if (element == document && document.createEvent && !element.dispatchEvent) element = document.documentElement; var event; if (document.createEvent) { event = document.createEvent('HTMLEvents'); event.initEvent('dataavailable', true, true); } else { event = document.createEventObject(); event.eventType = bubble ? 'ondataavailable' : 'onfilterchange'; } event.eventName = eventName; event.memo = memo || { }; if (document.createEvent) element.dispatchEvent(event); else element.fireEvent(event.eventType, event); return Event.extend(event); } Object.extend(Event, Event.Methods); Object.extend(Event, { fire: fire, observe: observe, stopObserving: stopObserving }); Element.addMethods({ fire: fire, observe: observe, stopObserving: stopObserving }); Object.extend(document, { fire: fire.methodize(), observe: observe.methodize(), stopObserving: stopObserving.methodize(), loaded: false }); if (window.Event) Object.extend(window.Event, Event); else window.Event = Event; })(); (function() { /* Support for the DOMContentLoaded event is based on work by Dan Webb, Matthias Miller, Dean Edwards, John Resig, and Diego Perini. */ var timer; function fireContentLoadedEvent() { if (document.loaded) return; if (timer) window.clearTimeout(timer); document.loaded = true; document.fire('dom:loaded'); } function checkReadyState() { if (document.readyState === 'complete') { document.stopObserving('readystatechange', checkReadyState); fireContentLoadedEvent(); } } function pollDoScroll() { try { document.documentElement.doScroll('left'); } catch(e) { timer = pollDoScroll.defer(); return; } fireContentLoadedEvent(); } if (document.addEventListener) { document.addEventListener('DOMContentLoaded', fireContentLoadedEvent, false); } else { document.observe('readystatechange', checkReadyState); if (window == top) timer = pollDoScroll.defer(); } Event.observe(window, 'load', fireContentLoadedEvent); })(); Element.addMethods(); /*------------------------------- DEPRECATED -------------------------------*/ Hash.toQueryString = Object.toQueryString; var Toggle = { display: Element.toggle }; Element.Methods.childOf = Element.Methods.descendantOf; var Insertion = { Before: function(element, content) { return Element.insert(element, {before:content}); }, Top: function(element, content) { return Element.insert(element, {top:content}); }, Bottom: function(element, content) { return Element.insert(element, {bottom:content}); }, After: function(element, content) { return Element.insert(element, {after:content}); } }; var $continue = new Error('"throw $continue" is deprecated, use "return" instead'); var Position = { includeScrollOffsets: false, prepare: function() { this.deltaX = window.pageXOffset || document.documentElement.scrollLeft || document.body.scrollLeft || 0; this.deltaY = window.pageYOffset || document.documentElement.scrollTop || document.body.scrollTop || 0; }, within: function(element, x, y) { if (this.includeScrollOffsets) return this.withinIncludingScrolloffsets(element, x, y); this.xcomp = x; this.ycomp = y; this.offset = Element.cumulativeOffset(element); return (y >= this.offset[1] && y < this.offset[1] + element.offsetHeight && x >= this.offset[0] && x < this.offset[0] + element.offsetWidth); }, withinIncludingScrolloffsets: function(element, x, y) { var offsetcache = Element.cumulativeScrollOffset(element); this.xcomp = x + offsetcache[0] - this.deltaX; this.ycomp = y + offsetcache[1] - this.deltaY; this.offset = Element.cumulativeOffset(element); return (this.ycomp >= this.offset[1] && this.ycomp < this.offset[1] + element.offsetHeight && this.xcomp >= this.offset[0] && this.xcomp < this.offset[0] + element.offsetWidth); }, overlap: function(mode, element) { if (!mode) return 0; if (mode == 'vertical') return ((this.offset[1] + element.offsetHeight) - this.ycomp) / element.offsetHeight; if (mode == 'horizontal') return ((this.offset[0] + element.offsetWidth) - this.xcomp) / element.offsetWidth; }, cumulativeOffset: Element.Methods.cumulativeOffset, positionedOffset: Element.Methods.positionedOffset, absolutize: function(element) { Position.prepare(); return Element.absolutize(element); }, relativize: function(element) { Position.prepare(); return Element.relativize(element); }, realOffset: Element.Methods.cumulativeScrollOffset, offsetParent: Element.Methods.getOffsetParent, page: Element.Methods.viewportOffset, clone: function(source, target, options) { options = options || { }; return Element.clonePosition(target, source, options); } }; /*--------------------------------------------------------------------------*/ if (!document.getElementsByClassName) document.getElementsByClassName = function(instanceMethods){ function iter(name) { return name.blank() ? null : "[contains(concat(' ', @class, ' '), ' " + name + " ')]"; } instanceMethods.getElementsByClassName = Prototype.BrowserFeatures.XPath ? function(element, className) { className = className.toString().strip(); var cond = /\s/.test(className) ? $w(className).map(iter).join('') : iter(className); return cond ? document._getElementsByXPath('.//*' + cond, element) : []; } : function(element, className) { className = className.toString().strip(); var elements = [], classNames = (/\s/.test(className) ? $w(className) : null); if (!classNames && !className) return elements; var nodes = $(element).getElementsByTagName('*'); className = ' ' + className + ' '; for (var i = 0, child, cn; child = nodes[i]; i++) { if (child.className && (cn = ' ' + child.className + ' ') && (cn.include(className) || (classNames && classNames.all(function(name) { return !name.toString().blank() && cn.include(' ' + name + ' '); })))) elements.push(Element.extend(child)); } return elements; }; return function(className, parentElement) { return $(parentElement || document.body).getElementsByClassName(className); }; }(Element.Methods); /*--------------------------------------------------------------------------*/ Element.ClassNames = Class.create(); Element.ClassNames.prototype = { initialize: function(element) { this.element = $(element); }, _each: function(iterator) { this.element.className.split(/\s+/).select(function(name) { return name.length > 0; })._each(iterator); }, set: function(className) { this.element.className = className; }, add: function(classNameToAdd) { if (this.include(classNameToAdd)) return; this.set($A(this).concat(classNameToAdd).join(' ')); }, remove: function(classNameToRemove) { if (!this.include(classNameToRemove)) return; this.set($A(this).without(classNameToRemove).join(' ')); }, toString: function() { return $A(this).join(' '); } }; Object.extend(Element.ClassNames.prototype, Enumerable); /*--------------------------------------------------------------------------*/ mlpost-0.8.1/examples/animations.ml0000644000443600002640000001071711365367177016541 0ustar kanigdemonsopen 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.1/examples/myocamlbuild.ml0000644000443600002640000000712311365367177017055 0ustar kanigdemonsopen 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.1/examples/color.ml0000644000443600002640000000200311365367177015502 0ustar kanigdemonsopen 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.1/examples/label.ml0000644000443600002640000000177411365367177015461 0ustar kanigdemonsopen 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.1/examples/cairo_test.ml0000644000443600002640000000453511365367177016534 0ustar kanigdemonsopen 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.1/examples/concrete.ml0000644000443600002640000000257611365367177016205 0ustar kanigdemonsopen 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.1/examples/README0000644000443600002640000000136211365367177014721 0ustar kanigdemonsTo 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.1/examples/misc.ml0000644000443600002640000005157511365367177015341 0ustar kanigdemonsopen 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.1/examples/boxes.ml0000644000443600002640000001357311365367177015522 0ustar kanigdemonsopen 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 débuggage 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.1/examples/automata.ml0000644000443600002640000001611011365367177016203 0ustar kanigdemons (* 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.1/examples/paths.ml0000644000443600002640000001030411365367177015506 0ustar kanigdemonsopen 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.1/examples/parse.mll0000644000443600002640000000517411365367177015666 0ustar kanigdemons{ open Lexing let togglescript = " hide mpost show cairo png 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 "
"; Printf.printf "" i; Printf.printf "show/hide code"; 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.1/examples/dot_dot.ml0000644000443600002640000000215511365367177016030 0ustar kanigdemons(* 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.1/examples/Makefile0000644000443600002640000000700011365367177015474 0ustar kanigdemonsMAX := 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) 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_metapost: $(ALL) 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) 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 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 $^ $@ %.tex: all.template sed -e 's/all/$*/' all.template > $@ %.ps: %.1 %.tex latex $* dvips -E $*.dvi -o # %.pdf: %.mps all.template2 # sed -e 's/all/$*/' all.template2 > $*.tex # pdflatex $* # %.mps: %.1 # cp $*.1 $*.mps ALLTEX:=$(ALL:.png=.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.1/examples/include.ml0000644000443600002640000000175411365367177016023 0ustar kanigdemonsopen 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.1/examples/hist.ml0000644000443600002640000000343011365367177015340 0ustar kanigdemonsopen 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.1/examples/style.css0000644000443600002640000000175711365367177015723 0ustar kanigdemonscode,pre { color:black;background-color:white }a.Cannot { color:black;text-decoration:none }.Cannot:hover { background-color: #b4eeb4; } .Cbar, .Cdo, .Cdone, .Cdownto, .Celse, .Cfor, .Cif, .Clazy, .Cmatch, .Cnew, .Cor, .Cthen, .Cto, .Ctry, .Cwhen, .Cwhile, .Cwith { color: #77aaaa; } .Cassert, .Cinclude, .Copen { color: #cc9900; } .Cstring { color: #aa4444; } .Cand, .Cas, .Cclass, .Cconstraint, .Cexception, .Cexternal, .Cfun, .Cfunction, .Cfunctor, .Cin, .Cinherit, .Cinitializer, .Clet, .Cmethod, .Cmodule, .Cmutable, .Cof, .Cprivate, .Crec, .Ctype, .Cval, .Cvirtual { color: green; } .Cbackground { background-color: white; } .Craise { color: red; } .Cconstructor { color: #0033cc; } .Ccomment { color: #990000; } .Calphakeyword, .Casr, .Cland, .Clor, .Clsl, .Clsr, .Clxor, .Cmod { color: #808080; } .Clinenum { color: black; background-color: silver; } .Cbegin, .Cend, .Cobject, .Csig, .Cstruct { color: #990099; } .Cfalse, .Cnonalphakeyword, .Cquotation, .Ctrue { } .table { float:left; margin:5px;}mlpost-0.8.1/examples/real_plot.ml0000644000443600002640000000216111365367177016352 0ustar kanigdemonsopen Mlpost open Real_plot open Printf (*parse <> *) (*parse < if f < 0. then None else Some (sqrt f)) "sqrt"; curve ceil "ceil"; curve floor "floor"; curve sin "sin"; curve_l [(fun f -> if f <= 0. then None else Some (1./.f)); (fun f -> if f >= 0. then None else Some (1./.f))] "$\\frac{1}{x}$"; ] in draw ~label:(fun x -> x) ~ymax:5. ~ymin:(-.5.) ~xmin:(-.5.) ~xmax:5. ~pitch:(0.01) ~width:(Num.cm 6.) ~height:(Num.cm 4.) graph (*parse >> < curve (fun f -> f**(1./.float_of_int i)) i) [2;3;4;8;12;15] in draw ~label:(sprintf "$\\sqrt[%i]{x}$") ~xmin:0. ~xmax:5. ~pitch:(0.01) ~width:(Num.cm 6.) ~height:(Num.cm 4.) curves (*parse >> *) let () = List.iter (fun (name,fig) -> Metapost.emit name (Picture.scale (Num.bp 3.) fig)) ["real_plot1",real_plot1; "real_plot2",real_plot2] mlpost-0.8.1/examples/tex.ml0000644000443600002640000000064111365367177015172 0ustar kanigdemonsopen Mlpost open Concrete open Command open Picture open CPoint let s = "Bonjour les amis $42_{la reponse}$" let p = let t = tex s in let bs = baselines s in let {x = left} = cpoint_of_point (west t) in let {x = right} = cpoint_of_point (east t) in let pl = List.map (fun e -> Path.path [left,e;right,e]) bs in let pl = List.map Path.draw pl in seq (t::pl) let () = Metapost.emit "baselines" p mlpost-0.8.1/dvi/0000755000443600002640000000000011365367167013002 5ustar kanigdemonsmlpost-0.8.1/dvi/metric.mli0000644000443600002640000000275611365367177015003 0ustar kanigdemonstype t = Tfm.t (* convenience interface for font metrics *) 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 (** [scaled_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.1/dvi/fonts_type.mli0000644000443600002640000000260511365367177015703 0ustar kanigdemons(**************************************************************************) (* *) (* 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.1/dvi/fonts.mli0000644000443600002640000000172211365367177014641 0ustar kanigdemonstype font_def val mk_font_def : checksum : int32 -> scale_factor : int32 -> design_size : int32 -> area: string -> name:string -> font_def type t val set_verbosity : bool -> unit val load_font : font_def -> float -> t val metric : t -> Tfm.t val tex_name : t -> string val glyphs_filename : t -> string (* the file, pfb or pfa, which defines the glyphs *) val glyphs_enc : t -> (int -> int) (* the conversion of the characters between tex and the font *) val ratio_cm : t -> float val slant : t -> float option val extend : t -> float option val t1disasm : string option ref module Print : sig val font : int32 -> Format.formatter -> font_def -> unit end val char_width : t -> int -> float val char_height : t -> int -> float val char_depth : t -> int -> float 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] *) mlpost-0.8.1/dvi/metric.ml0000644000443600002640000000156411365367177014626 0ustar kanigdemonstype 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.1/dvi/t1disasm.ml0000644000443600002640000001374411365367177015073 0ustar kanigdemons(**************************************************************************) (* *) (* 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 Int32 type t = Int32.t let init = of_int 55665 let c1 = of_int 52845 let c2 = of_int 22719 let max16 = of_int 65536 let mask16 = of_int 65535 let random_bytes = 4 let enc_int r plain = let er = !r in let cipher = logxor plain (shift_right_logical !r 8) in let tmp2 = add (mul (add cipher !r) c1) c2 in r := logand tmp2 mask16 (*rem tmp2 max16*); Format.printf "ENC : @[tmp2 = %li@.er = %li@.cipher = %li@.plain = %li@]@." tmp2 er cipher plain; cipher let dec_int r cipher = (*let er = !r in*) let plain = logxor cipher (shift_right_logical !r 8) in let tmp2 = add (mul (add cipher !r) c1) c2 in r := logand tmp2 mask16 (*rem tmp2 max16*); (*Format.printf "DEC : @[tmp2 = %li@.r = %li@.cipher = %li@.plain = %li@]@." tmp2 er cipher plain;*) plain let dec_char r cipher = let cipher = of_int (int_of_char cipher) in let plain = dec_int r cipher in char_of_int (to_int plain) let dec_string r scipher = for i=0 to String.length scipher - 1 do scipher.[i] <- dec_char r scipher.[i] done let dec_channel_for_lexer ic = let r = ref init in let s = String.make random_bytes ' ' in ignore (input ic s 0 random_bytes); dec_string r s; Lexing.from_function (fun buf n -> let n = input ic buf 0 n in dec_string r buf; n) let rc_start = "RD" let to_suppres = ref 0 let suppres buf_out buf_tmp start len = Buffer.add_substring buf_out buf_tmp 0 start; let buflen = String.length buf_tmp in if len+start (*Printf.printf "Scanf dup : %s\n" s;*) try Scanf.bscanf tmp "%_s %n%i RD %n" scanf_f; with Scanf.Scan_failure _ | End_of_file-> (*Printf.printf "Scanf other : %s\n" s;*) Buffer.add_string buf_out buf_tmp end let dec_buffer ch len buf_out = let buf_tmp = Buffer.create 30 in let r = ref init in for i=0 to len -1 do let dec = (dec_char r (input_char ch)) in if dec == '\013' then Buffer.add_char buf_tmp '\n' else if dec != '\n' then Buffer.add_char buf_tmp dec else (eexec_line (Buffer.contents buf_tmp) buf_out; Buffer.clear buf_tmp) done let all ch = let r = ref init in while true do let c = input_char ch in let dc = dec_char r c in Format.printf "(%c,%i) -> (%c,%i)@." c (int_of_char c) dc (int_of_char dc) done let rec input_char_list ch = function | 0 -> [] | n -> let c = input_char ch in c::(input_char_list ch (n-1)) let rec decale = function | [] -> () | _::tl as l -> let r = ref init in let l = List.map (dec_char r) l in Format.printf "LINE : %i\n" (List.length l); Format.printf "%a@.@." (fun fmt -> List.iter (Format.fprintf fmt "%c")) l; decale tl let search ch = let l = input_char_list ch 100 in decale l let show ch = while true do let c = input_char ch in Format.printf "(%c,%i);\n" c (int_of_char c) done let input_binary_int_little ch = let f x n = logor x (shift_left (of_int (int_of_char (input_char ch))) n) in to_int (f (f (f (f zero 0) 8) 16) 24) type pfb_marker = | PFB_MARKER | PFB_ASCII | PFB_BINARY | PFB_DONE | NOTPFB of char let conv_marker = function | '\001' -> PFB_ASCII | '\002' -> PFB_BINARY | '\003' -> PFB_DONE | '\128' -> PFB_MARKER | c -> NOTPFB c let find_block ch = let buf_out = Buffer.create 1000 in let rec find_block_aux () = let c = conv_marker (input_char ch) in let blocktyp = conv_marker (input_char ch) in match c,blocktyp with | PFB_MARKER, PFB_DONE -> () | PFB_MARKER, PFB_ASCII -> let block_len = input_binary_int_little ch in for i=0 to block_len -1 do let c = input_char ch in if c == '\013' then Buffer.add_char buf_out '\n' else Buffer.add_char buf_out c done; find_block_aux () | PFB_MARKER, PFB_BINARY -> let block_len = input_binary_int_little ch in dec_buffer ch block_len buf_out; find_block_aux () | _ -> failwith "pfb format error, try with t1disasm" in find_block_aux (); buf_out let open_decr filename = let ch = open_in_bin filename in find_block ch let print_block ch = Buffer.output_buffer stdout (find_block ch) (*let _ = let ch = open_in_bin Sys.argv.(1) in print_block ch *) mlpost-0.8.1/dvi/pfb_parser.mly0000644000443600002640000000347211365367177015657 0ustar kanigdemons/**************************************************************************/ /* */ /* 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.1/dvi/tfm.mli0000644000443600002640000000210411365367177014271 0ustar kanigdemonstype 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 } val read_file : string -> t mlpost-0.8.1/dvi/myocamlbuild.ml0000644000443600002640000000701511365367177016021 0ustar kanigdemonsopen 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.1/dvi/fonts.ml0000644000443600002640000002312611365367177014472 0ustar kanigdemons(**************************************************************************) (* *) (* 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. *) (* *) (**************************************************************************) exception Fonterror of string let font_error s = raise (Fonterror s) type glyphs = { glyphs_filename : string; (* the file, pfb or pfa, which define the glyphs *) glyphs_enc : int -> int; (* the conversion of the characters between tex and the font *) } 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 } type t = { tex_name : string; metric : Tfm.t; glyphs_filename : string; (* 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; ratio : float; ratio_cm : float } let debug = ref false let info = ref false let tex_name t = t.tex_name let glyphs_filename t = t.glyphs_filename let glyphs_enc t = t.glyphs_enc let ratio_cm t = t.ratio_cm let slant t = t.slant let extend t = t.extend let metric t = t.metric let scale t f = t.ratio_cm *. f let set_verbosity b = info := b module Print = 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 let kwhich = "kpsewhich" let t1disasm = ref None (*"t1disasm"*) 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 font_error "kwhich failed" 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 open_pfb_decrypted filename = match !t1disasm with | None -> let buf = T1disasm.open_decr filename in (*Buffer.output_buffer stdout buf;*) Lexing.from_string (Buffer.contents buf), fun () -> () | Some t1disasm -> let temp_fn = Filename.temp_file "pfb_human" "" in let exit_status = Sys.command (Format.sprintf "%s %s > %s" t1disasm filename temp_fn) in if exit_status <> 0 then font_error "pfb_human generation failed" else let file = open_in temp_fn in Lexing.from_channel file,(fun () -> Sys.remove temp_fn) let load_pfb_aux filename = if !info then Format.printf "Loading font from %s...@?" filename; let lexbuf,do_done = open_pfb_decrypted filename in try let encoding_table, charstring = Pfb_parser.pfb_human_main Pfb_lexer.pfb_human_token lexbuf in let charstring_table = Hashtbl.create 700 in let count = ref 0 in List.iter (fun x -> Hashtbl.add charstring_table x !count;incr(count)) charstring; if !info then Format.printf "done@."; do_done (); encoding_table,charstring_table 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 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) (match !Pfb_lexer.state with |Pfb_lexer.Header -> "header" | Pfb_lexer.Encoding -> "encoding" | Pfb_lexer.Charstring -> "charstring") ; raise a let load_pfb = memoize load_pfb_aux 15 let load_fonts_map filename = if !info then Format.printf "Load font map from %s...@?" filename; let file = open_in filename in let lexbuf = Lexing.from_channel file in try 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 !info then Format.printf "done@."; table 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 Format.eprintf "file %s, line %i, characters %i-%i : %s parse_error@." filename p_start.Lexing.pos_lnum p_start.Lexing.pos_bol p_end.Lexing.pos_bol (Lexing.lexeme lexbuf); raise a let load_enc_aux filename = if !info then Format.printf "Loading enc from %s...@?" filename; let file = open_in filename in let lexbuf = Lexing.from_channel file in try 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 !info then Format.printf "done@."; enc_table 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 Format.eprintf "file %s, line %i, characters %i-%i : %s parse_error@." filename p_start.Lexing.pos_lnum p_start.Lexing.pos_bol p_end.Lexing.pos_bol (Lexing.lexeme lexbuf); raise a 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 !info 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 !debug then Format.printf "Trying to find metrics at %s...@." filename; let tfm = Tfm.read_file filename in if (Int32.compare tfm.Tfm.body.Tfm.header.Tfm.checksum fd.checksum <> 0) then font_error "Metrics checksum do not match !.@."; if !debug then Format.printf "Metrics successfully loaded for font %s from %s.@." fd.name filename; if !info then Format.printf "done@."; tfm let compute_trans_enc encoding_table charset_table char = Hashtbl.find charset_table (encoding_table.(char)) let load_font doc_conv fdef = let tex_name = fdef.name in let font_map = try HString.find (Lazy.force fonts_map_table) tex_name with Not_found -> invalid_arg ("Unknown font : "^tex_name) in let tfm = load_font_tfm fdef in let pfab = find_file font_map.Fonts_type.pfab_name in let pfab_enc,pfab_charset = load_pfb pfab in let enc = match font_map.Fonts_type.enc_name with | None -> pfab_enc | Some x -> load_enc (find_file x) in let glyphs_enc = compute_trans_enc enc pfab_charset 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 { tex_name = tex_name; metric = tfm; glyphs_filename = pfab; glyphs_enc = glyphs_enc; slant = font_map.Fonts_type.slant; extend = font_map.Fonts_type.extend; 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) with Not_found -> let result = load_font doc_conv fdef in Hashtbl.add memoize (doc_conv,fdef) 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.1/dvi/dev_save.mli0000644000443600002640000000050011365367177015275 0ustar kanigdemonstype t module Dev_save : Dviinterp.dev with type arg = bool and type cooked = t val separe_pages : t -> t list val get_dimen_first_page : t -> float * float * float * float val get_bases_first_page : t -> float list module Dev_load ( Dev : Dviinterp.dev ) : sig val replay : bool -> t -> Dev.arg -> Dev.cooked end mlpost-0.8.1/dvi/dev_save.ml0000644000443600002640000001510611365367177015134 0ustar kanigdemons(**************************************************************************) (* *) (* 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 Tfm open Fonts type command = | Rectangle of Dviinterp.info*float * float * float * float (* x,y,w,h *) | Glyph of Dviinterp.info*Fonts.t * Int32.t * float * float | Specials of Dviinterp.info*string * float *float (* s,x,y *) type page = { c : command list; x_min : float; y_min : float; x_max : float; y_max : float; bases : float list } let stroke = 0.05 type t = {mutable pages : page list; doc : Dvi.t} let replay_page_aux trace fill_rect draw_char specials dev page = List.iter (function |Rectangle (info,x,y,w,h) -> fill_rect dev info x y w h |Glyph (info,font,char,x,y) -> draw_char dev info font char x y |Specials (info,xxx,x,y) -> specials dev info xxx x y) page.c; if trace then begin let h = page.y_max -. page.y_min in let w = page.x_max -. page.x_min in let msd x = x -. stroke/.2. in fill_rect dev Dviinterp.dumb_info page.x_min (msd page.y_min) w stroke; fill_rect dev Dviinterp.dumb_info (msd page.x_min) page.y_min stroke h; fill_rect dev Dviinterp.dumb_info page.x_min (msd page.y_max) w stroke; fill_rect dev Dviinterp.dumb_info (msd page.x_max) page.y_min stroke h end let replay trace new_document new_page fill_rect draw_char specials end_document saved arg = let dev = new_document arg saved.doc in List.iter (fun page -> new_page dev; replay_page_aux trace fill_rect draw_char specials dev page) saved.pages; end_document dev let separe_pages saved = List.map (fun page -> {pages = [page];doc=saved.doc}) saved.pages let get_doc s = s.doc let get_dimen_page s = (s.x_min,s.y_min,s.x_max,s.y_max) let get_dimen_first_page s = get_dimen_page (List.hd s.pages) let get_bases_first_page s = (List.hd s.pages).bases let nb_pages s = List.length s.pages module Dev_save : Dviinterp.dev with type arg = bool with type cooked = t = struct type arg = bool type cooked = t type t = { mutable tpages : page list; tdoc : Dvi.t; mutable tfirst_page : bool; mutable tc : command list; mutable tx_min : float; mutable ty_min : float; mutable tx_max : float; mutable ty_max : float; mutable tbases : float list; use_last_vrule : bool} let new_document use_last_vrule doc = { tpages = []; tdoc = doc; tfirst_page = true; tc = []; tx_min = infinity; tx_max = neg_infinity; ty_min = infinity; ty_max = neg_infinity; tbases = []; use_last_vrule = use_last_vrule } let new_page s = if s.tfirst_page then s.tfirst_page<-false else begin let page = match s.use_last_vrule, s.tc with | false, _ -> {c = List.rev s.tc; x_min = s.tx_min; y_min = s.ty_min; x_max = s.tx_max; y_max = s.ty_max; bases = s.tbases; } (* Dans ce cas on utilise une vrule qui est mis specialement pour connaitre la taille du tex vphantom *) (* Cependant le y donné est très étrange *) | true, (Rectangle (_,x,y,_,h))::l -> {c = List.rev l; x_min = 0.; y_min = -.(y+.h); x_max = x; y_max = -.y; bases = s.tbases; } | _ -> failwith "I thought there were always a vrule at the end,\ please report. thx" in (*Format.eprintf "x_min = %f; x_max = %f; y_min = %f; y_max = %f@." page.x_min page.x_max page.y_min page.y_max;*) s.tpages <- page::s.tpages; s.tc <- []; s.tx_min <- infinity; s.tx_max <- neg_infinity; s.ty_min <- infinity; s.ty_max <- neg_infinity; s.tbases <- [] end let fill_rect s info x y w h = s.tc <- (Rectangle (info,x,y,w,h))::s.tc; if not s.use_last_vrule then let xmin,xmax = x,x+.w(*min x (x+.w), max x (x+.w)*) in let ymin,ymax = y,y+.h(*min y (y+.h), max y (y+.h)*) in s.tx_min <- (min s.tx_min xmin); s.ty_min <- (min s.ty_min ymin); s.tx_max <- (max s.tx_max xmax); s.ty_max <- (max s.ty_max ymax) let draw_char s info font char x y = s.tc <- (Glyph (info,font,char,x,y))::s.tc; if not (List.mem y s.tbases) then s.tbases <- y::s.tbases; if not s.use_last_vrule then let width,height,depth = Fonts.char_dims font (Int32.to_int char) in s.tx_min <- min s.tx_min x; s.ty_min <- min s.ty_min (y-.depth); s.tx_max <- max s.tx_max (x+.width); s.ty_max <- max s.ty_max (y+.height) let specials s info xxx x y = s.tc <- (Specials (info,xxx,x,y))::s.tc let end_document s = new_page s; {pages = List.rev s.tpages; doc = s.tdoc} end module Dev_load (Dev : Dviinterp.dev) = struct let replay trace = replay trace Dev.new_document Dev.new_page Dev.fill_rect Dev.draw_char Dev.specials Dev.end_document let load_doc saved doc arg = if get_doc saved = doc then replay false saved arg else invalid_arg ("The dvi doc is different") end mlpost-0.8.1/dvi/dviinterp.ml0000644000443600002640000002032411365367177015342 0ustar kanigdemons(**************************************************************************) (* *) (* 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 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 push pop *) type state = { h : int32; v : int32; w : int32; x : int32; y : int32; z : int32; } (* an env can't *) type 'a env = { dev : 'a; mutable ecolor : color; color_stack : color Stack.t; conv : float; mutable font : Int32.t; stack : state Stack.t; mutable s : state } type info = { color : color } let dumb_info = {color = Gray 0.} let info_of_env env = {color = env.ecolor} let new_env dev conv = {dev = dev; 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 (); } 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 module type dev = sig type t type arg type cooked val new_document : arg -> Dvi.t -> t val new_page : t -> unit val fill_rect : t -> info -> float -> float -> float -> float -> unit (* fill_rect t x y w h *) val draw_char : t -> info -> Fonts.t -> Int32.t -> float -> float -> unit (* draw_char t font code x y *) val specials : t -> info -> string -> float -> float -> unit (* specials t s x y *) val end_document : t -> cooked end module Interp (Dev : dev) = struct let verbose = ref false let set_verbosity b = verbose := b; Fonts.set_verbosity b let debug = ref false let set_debug = (:=) debug let reset dev conv = Dev.new_page dev; new_env dev conv 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_char env font code = let x = env.conv *. (Int32.to_float env.s.h) and y = env.conv *. (Int32.to_float env.s.v) in Dev.draw_char env.dev (info_of_env env) font code x y let put_rule env 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 Dev.fill_rect env.dev (info_of_env env) x (y -. h) w h let interp_command fm env = function | Dvi.SetChar c -> if !debug then printf "Setting character %ld.@." c; let font = Int32Map.find env.font fm in let fwidth = Fonts.char_width font (Int32.to_int c) in let width = Int32.of_float fwidth in if !debug then printf "Character found in font %ld. Width = %ld@." env.font width; put_char env font c; env.s <- {env.s with h = Int32.add env.s.h width} | Dvi.SetRule(a, b) -> if !debug then printf "Setting rule (w=%ld, h=%ld).@." a b; put_rule env a b; env.s <- {env.s with h = Int32.add env.s.h b} | Dvi.PutChar c -> if !debug then printf "Putting character %ld.@." c; put_char env (Int32Map.find env.font fm) c | Dvi.PutRule(a, b) -> if !debug then printf "Putting rule (w=%ld, h=%ld).@." a b; put_rule env a b | Dvi.Push -> if !debug then printf "Push current state.@."; Stack.push env.s env.stack | Dvi.Pop -> (try if !debug then printf "Pop current state.@."; env.s <- Stack.pop env.stack with Stack.Empty -> failwith "Empty stack !") | Dvi.Right b -> if !debug then printf "Moving right %ld.@." b; env.s<-{env.s with h = Int32.add env.s.h b} | Dvi.Wdefault -> if !debug then printf "Moving right by the default W.@."; env.s<-{env.s with h = Int32.add env.s.h env.s.w} | Dvi.W b -> if !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} | Dvi.Xdefault -> if !debug then printf "Moving right by the default X.@."; env.s<-{env.s with h = Int32.add env.s.h env.s.x} | Dvi.X b -> if !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} | Dvi.Down a -> if !debug then printf "Moving down %ld.@." a; env.s <- {env.s with v = Int32.add env.s.v a} | Dvi.Ydefault -> if !debug then printf "Moving down by the default Y.@."; env.s <- {env.s with v = Int32.add env.s.v env.s.y} | Dvi.Y a -> if !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} | Dvi.Zdefault -> if !debug then printf "Moving down by the default Z.@."; env.s <- {env.s with v = Int32.add env.s.v env.s.z} | Dvi.Z a -> if !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} | Dvi.FontNum f -> env.font <- f; if !debug then printf "Font is now set to %ld@." f | Dvi.Special xxx -> if !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 in scanf_with xxx (fun s -> Dev.specials env.dev (info_of_env env) s x y) [(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 <- Stack.pop env.color_stack));] let interp_page dev conv fm p = List.iter (interp_command fm (reset dev conv)) (List.rev (Dvi.commands p)) let load_fonts font_map conv = Int32Map.fold (fun k fdef -> Int32Map.add k (Fonts.load_font fdef conv) ) font_map Int32Map.empty let load_doc arg doc = let conv = Dvi.get_conv doc in let fonts = load_fonts (Dvi.fontmap doc) conv in let dev = Dev.new_document arg doc in List.iter (fun p -> if !debug then printf "#### Starting New Page ####@." else if !verbose then printf "."; interp_page dev conv fonts p) (Dvi.pages doc); Dev.end_document dev let load_file arg file = let doc = Dvi.read_file file in if !verbose then printf "Dvi file parsing and interpretation :@.@?"; let res = load_doc arg doc in if !verbose then printf " done@.@?"; res end mlpost-0.8.1/dvi/dvi.mli0000644000443600002640000000101111365367177014261 0ustar kanigdemons 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 type t val get_conv : t -> float val fontmap : t -> Fonts.font_def Dvi_util.Int32Map.t val commands : page -> command list val pages : t -> page list val read_file : string -> t mlpost-0.8.1/dvi/_tags0000644000443600002640000000017711365367177014030 0ustar kanigdemons or : syntax_bitstring or : pkg_bitstring, pkg_bitstring.syntax <*.cmx> : for-pack(Mlpost) mlpost-0.8.1/dvi/pfb_lexer.mll0000644000443600002640000000666611365367177015475 0ustar kanigdemons(**************************************************************************) (* *) (* 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} | ']' _* eof {DUMB} { let pfb_human_token x = match !state with |Header -> header_token x |Encoding -> encoding_token x |Charstring -> charstring_token x } mlpost-0.8.1/dvi/t1disasm.mli0000644000443600002640000000004311365367177015230 0ustar kanigdemonsval open_decr : string -> Buffer.t mlpost-0.8.1/dvi/tfm.ml0000644000443600002640000002101711365367177014124 0ustar kanigdemons(**************************************************************************) (* *) (* 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 let debug = ref false 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 !debug then Print.file_hdr std_formatter fh; let body = body fh bits in { file_hdr = fh; body = body } mlpost-0.8.1/dvi/map_lexer.mll0000644000443600002640000000422111365367177015464 0ustar kanigdemons(**************************************************************************) (* *) (* 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.1/dvi/dvi.ml0000644000443600002640000003720611365367177014127 0ustar kanigdemons(**************************************************************************) (* *) (* 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 t = { preamble : preamble; pages : page list; postamble : postamble; postpostamble : postpostamble; font_map : Fonts.font_def Int32Map.t } 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 page 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; fprintf fmt "\t" let pages fmt = List.iter (fun p -> fprintf fmt "%a\n" page p) let fonts fmt fonts = fprintf fmt "* Fonts defined in this file :\n"; Int32Map.iter (fun k f -> Fonts.Print.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 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 } -> Fonts.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 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 = 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 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 = 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 get_conv doc = 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 doc.preamble.pre_mag doc.preamble.pre_num doc.preamble.pre_den 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 mlpost-0.8.1/dvi/dviinterp.mli0000644000443600002640000000141711365367177015515 0ustar kanigdemonstype color = | RGB of float * float * float | CMYK of float * float * float * float | HSB of float * float * float | Gray of float type info = { color : color } val dumb_info : info module type dev = sig type t type arg type cooked val new_document : arg -> Dvi.t -> t val new_page : t -> unit val fill_rect : t -> info -> float -> float -> float -> float -> unit (* fill_rect t x y w h *) val draw_char : t -> info -> Fonts.t -> Int32.t -> float -> float -> unit (* draw_char t font code x y *) val specials : t -> info -> string -> float -> float -> unit (* specials t s x y *) val end_document : t -> cooked end module Interp (Dev : dev) : sig val set_verbosity : bool -> unit val load_file : Dev.arg -> string -> Dev.cooked end mlpost-0.8.1/dvi/map_parser.mly0000644000443600002640000000543511365367177015666 0ustar kanigdemons/**************************************************************************/ /* */ /* 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.1/dvi/dvi_util.ml0000644000443600002640000000012611365367177015153 0ustar kanigdemonsmodule Int32Map = Map.Make(struct type t = int32 let compare = Int32.compare end) mlpost-0.8.1/hashcons.ml0000644000443600002640000002162111365367177014363 0ustar kanigdemons(**************************************************************************) (* *) (* 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. *) (* *) (**************************************************************************) (* * hashcons: hash tables for hash consing * Copyright (C) 2000 Jean-Christophe FILLIATRE * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Library General Public * License version 2, as published by the Free Software Foundation. * * 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 Library General Public License version 2 for more details * (enclosed in the file LGPL). *) (*s Hash tables for hash-consing. (Some code is borrowed from the ocaml standard library, which is copyright 1996 INRIA.) *) type 'a hash_consed = { hkey : int; tag : int; node : 'a } let gentag = let r = ref 0 in fun () -> incr r; !r type 'a t = { mutable table : 'a hash_consed Weak.t array; mutable totsize : int; (* sum of the bucket sizes *) mutable limit : int; (* max ratio totsize/table length *) } let create sz = let sz = if sz < 7 then 7 else sz in let sz = if sz > Sys.max_array_length then Sys.max_array_length else sz in let emptybucket = Weak.create 0 in { table = Array.create sz emptybucket; totsize = 0; limit = 3; } let clear t = let emptybucket = Weak.create 0 in for i = 0 to Array.length t.table - 1 do t.table.(i) <- emptybucket done; t.totsize <- 0; t.limit <- 3 let fold f t init = let rec fold_bucket i b accu = if i >= Weak.length b then accu else match Weak.get b i with | Some v -> fold_bucket (i+1) b (f v accu) | None -> fold_bucket (i+1) b accu in Array.fold_right (fold_bucket 0) t.table init let iter f t = let rec iter_bucket i b = if i >= Weak.length b then () else match Weak.get b i with | Some v -> f v; iter_bucket (i+1) b | None -> iter_bucket (i+1) b in Array.iter (iter_bucket 0) t.table let count t = let rec count_bucket i b accu = if i >= Weak.length b then accu else count_bucket (i+1) b (accu + (if Weak.check b i then 1 else 0)) in Array.fold_right (count_bucket 0) t.table 0 let next_sz n = min (3*n/2 + 3) (Sys.max_array_length - 1) let rec resize t = let oldlen = Array.length t.table in let newlen = next_sz oldlen in if newlen > oldlen then begin let newt = create newlen in newt.limit <- t.limit + 100; (* prevent resizing of newt *) fold (fun d () -> add newt d) t (); t.table <- newt.table; t.limit <- t.limit + 2; end and add t d = let index = d.hkey mod (Array.length t.table) in let bucket = t.table.(index) in let sz = Weak.length bucket in let rec loop i = if i >= sz then begin let newsz = min (sz + 3) (Sys.max_array_length - 1) in if newsz <= sz then failwith "Hashcons.Make: hash bucket cannot grow more"; let newbucket = Weak.create newsz in Weak.blit bucket 0 newbucket 0 sz; Weak.set newbucket i (Some d); t.table.(index) <- newbucket; t.totsize <- t.totsize + (newsz - sz); if t.totsize > t.limit * Array.length t.table then resize t; end else begin if Weak.check bucket i then loop (i+1) else Weak.set bucket i (Some d) end in loop 0 let hashcons t d = let hkey = Hashtbl.hash d in let index = hkey mod (Array.length t.table) in let bucket = t.table.(index) in let sz = Weak.length bucket in let rec loop i = if i >= sz then begin let hnode = { hkey = hkey; tag = gentag (); node = d } in add t hnode; hnode end else begin match Weak.get_copy bucket i with | Some v when v.node = d -> begin match Weak.get bucket i with | Some v -> v | None -> loop (i+1) end | _ -> loop (i+1) end in loop 0 let stats t = let len = Array.length t.table in let lens = Array.map Weak.length t.table in Array.sort compare lens; let totlen = Array.fold_left ( + ) 0 lens in (len, count t, totlen, lens.(0), lens.(len/2), lens.(len-1)) (* Functorial interface *) module type HashedType = sig type t val equal : t -> t -> bool val hash : t -> int end module type S = sig type key type t val create : int -> t val clear : t -> unit val hashcons : t -> key -> key hash_consed val iter : (key hash_consed -> unit) -> t -> unit val stats : t -> int * int * int * int * int * int end module Make(H : HashedType) : (S with type key = H.t) = struct type key = H.t type data = H.t hash_consed type t = { mutable table : data Weak.t array; mutable totsize : int; (* sum of the bucket sizes *) mutable limit : int; (* max ratio totsize/table length *) } let emptybucket = Weak.create 0 let create sz = let sz = if sz < 7 then 7 else sz in let sz = if sz > Sys.max_array_length then Sys.max_array_length else sz in { table = Array.create sz emptybucket; totsize = 0; limit = 3; } let clear t = for i = 0 to Array.length t.table - 1 do t.table.(i) <- emptybucket done; t.totsize <- 0; t.limit <- 3 let fold f t init = let rec fold_bucket i b accu = if i >= Weak.length b then accu else match Weak.get b i with | Some v -> fold_bucket (i+1) b (f v accu) | None -> fold_bucket (i+1) b accu in Array.fold_right (fold_bucket 0) t.table init let iter f t = let rec iter_bucket i b = if i >= Weak.length b then () else match Weak.get b i with | Some v -> f v; iter_bucket (i+1) b | None -> iter_bucket (i+1) b in Array.iter (iter_bucket 0) t.table let count t = let rec count_bucket i b accu = if i >= Weak.length b then accu else count_bucket (i+1) b (accu + (if Weak.check b i then 1 else 0)) in Array.fold_right (count_bucket 0) t.table 0 let next_sz n = min (3*n/2 + 3) (Sys.max_array_length - 1) let rec resize t = let oldlen = Array.length t.table in let newlen = next_sz oldlen in if newlen > oldlen then begin let newt = create newlen in newt.limit <- t.limit + 100; (* prevent resizing of newt *) fold (fun d () -> add newt d) t (); t.table <- newt.table; t.limit <- t.limit + 2; end and add t d = let index = d.hkey mod (Array.length t.table) in let bucket = t.table.(index) in let sz = Weak.length bucket in let rec loop i = if i >= sz then begin let newsz = min (sz + 3) (Sys.max_array_length - 1) in if newsz <= sz then failwith "Hashcons.Make: hash bucket cannot grow more"; let newbucket = Weak.create newsz in Weak.blit bucket 0 newbucket 0 sz; Weak.set newbucket i (Some d); t.table.(index) <- newbucket; t.totsize <- t.totsize + (newsz - sz); if t.totsize > t.limit * Array.length t.table then resize t; end else begin if Weak.check bucket i then loop (i+1) else Weak.set bucket i (Some d) end in loop 0 let hashcons t d = let hkey = H.hash d in let index = hkey mod (Array.length t.table) in let bucket = t.table.(index) in let sz = Weak.length bucket in let rec loop i = if i >= sz then begin let hnode = { hkey = hkey; tag = gentag (); node = d } in add t hnode; hnode end else begin match Weak.get_copy bucket i with | Some v when H.equal v.node d -> begin match Weak.get bucket i with | Some v -> v | None -> loop (i+1) end | _ -> loop (i+1) end in loop 0 let stats t = let len = Array.length t.table in let lens = Array.map Weak.length t.table in Array.sort compare lens; let totlen = Array.fold_left ( + ) 0 lens in (len, count t, totlen, lens.(0), lens.(len/2), lens.(len-1)) end mlpost-0.8.1/hist.ml0000644000443600002640000002300211365367177013517 0ustar kanigdemons(**************************************************************************) (* *) (* 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 Command open Color open Box open Num open Point open Path type 'a labels = Values | User of 'a list type path_3D = Prems of (Path.t*Path.t*Color.t) |PasPrems of (Path.t*Color.t) module Q = Misc.Q let max l = let rec max_aux acc = function |[]->acc |x::res-> if (x>acc) then max_aux x res else max_aux acc res in max_aux (List.hd l) l let maxlist l = let rec max_aux acc = function |[]->acc |x::res -> let m= max x in if (m>acc) then max_aux m res else max_aux acc res in max_aux (max (List.hd l)) l (* Valeur maximale dans un histogramme cumulé *) let maxcumul l = let rec list_aux acc l = match l with |[] -> acc |x::res -> list_aux ((List.fold_left (fun acc x -> acc+.x) 0. x)::acc) res in max (list_aux [] l) (* Ne fonctionne que si b est une hbox qui contient au moins une boite *) let move_hbox cumul cpt scalex b = let p = Box.south_west b in Box.shift (Point.pt (multf (float cpt) scalex,zero)) (Box.shift (Point.sub Point.origin p) b) let default_vlabel i _ = Some (Picture.tex (string_of_int i)) let laxe ~nbcol ?(vlabel=default_vlabel) padding scalex scaley hcaption vcaption valmax nbval = let hlabel i x = None in let axe = Plot.mk_skeleton (nbval/nbcol) (int_of_float valmax) (addn (multf (float nbcol) scalex) padding) scaley in Plot.draw_axes ?hcaption ?vcaption ~vlabel ~hlabel ~ticks:None axe let rec draw_perspect acc = function |Prems (p1,p2,c)::r -> draw_perspect ((fill ~color:c p1)++(fill ~color:c p2)++(Command.draw p1)++(Command.draw p2)++acc) r |PasPrems (p,c)::r -> draw_perspect ((fill ~color:c p)++(Command.draw p)++acc) r |[] -> acc (* Construit les composantes 3D à partir d'un vecteur, d'une boite et d'une couleur *) let perspect scale derns b c = let c = match c with |None -> Color.white |Some i -> i in let nw = north_west b in let ne = north_east b in let se = south_east b in let dep = divf scale 3. in let p1 = [nw;ne;pt ((addn (xpart ne) dep),(addn (ypart ne) dep)); pt ((addn (xpart nw) dep),(addn (ypart nw) dep))] in let p2 = [ne;se;pt ((addn (xpart se) dep),(addn (ypart se) dep)); pt ((addn (xpart ne) dep),(addn (ypart ne) dep))] in let path1 = pathp ~cycle:jLine ~style:jLine p1 in let path2 = pathp ~cycle:jLine ~style:jLine p2 in (* (fill ~color:c path1) ++ (fill ~color:c path2) ++ *) (* (Command.draw path1) ++ (Command.draw path2) *) if derns then Prems (path1,path2,c) else PasPrems(path2,c) let rec mk_perspect2 acc prems scale hb i j l = match l with |x::res -> let b = Box.nth j (Box.nth i hb) in let paths = perspect scale prems b (get_fill b) in mk_perspect2 (paths::acc) false scale hb i (j+1) res |[]-> acc let box_perspect scale hb l = let rec mk_perspect acc scale hb i l = match l with |x::res -> mk_perspect ((mk_perspect2 [] true scale hb i 0 x)@acc) scale hb (i+1) res |[] -> acc in mk_perspect [] scale hb 0 l (* Gère la position du label pour qu'elle soit cohérente *) let label_direction poslab x = match Types.vreduce poslab with | `North -> if x < 0. then (`South,Box.south) else (`South,Box.north) | `South -> if x < 0. then (`North,Box.south) else (`South,Box.north) | `Center -> (`Center,Box.ctr) let rec mk_labels2 acc poslab i j hb l l2= match l,l2 with |x::res,x2::res2 -> let sens,haut = label_direction poslab x2 in let b = Box.nth j (Box.nth i hb) in mk_labels2 (acc++ Command.label ~pos:sens x (haut b)) poslab i (j+1) hb res res2 |[],[]-> acc |_,_ -> failwith "Both datas and labels lists must have the same size" (* Positionne les labels sur chaque élément de l'histogramme *) let box_labels lab hb l = let rec mk_labels acc poslab i hb l l2= match l,l2 with |x::res,x2::res2 -> mk_labels (acc++mk_labels2 Command.nop poslab i 0 hb (List.rev x) (List.rev x2)) poslab (i+1) hb res res2 |[],[]-> acc |_,_ -> failwith "Both datas and labels lists must have the same size" in match lab with |(poslab,Values) -> let picl2 l = List.map (fun x -> Picture.tex (string_of_float x)) l in let picl l = List.map (fun x -> picl2 x) l in mk_labels nop poslab 0 hb (picl l) l |(poslab,User pl) -> mk_labels nop poslab 0 hb pl l (* Positionne les labels sous chaque barre *) let hist_labels hlab hb = let rec mk_labels acc i hlab = match hlab with |x::res -> mk_labels (acc ++ (Command.label ~pos:`South x) (Box.south (Box.nth i hb))) (i+1) res |[]-> acc in mk_labels nop 0 hlab (* Fonction de dessin d'histogramme *) let hist ~cumul width height padding fill perspective scalex scaley ?histlabel ?hlabel cpt l = let rec consvbox boxs = function |[],cq -> vbox boxs,cq |x::res, cq -> let c, cq = Q.pop cq in let b = (set_fill c (set_stroke black (empty ~width:scalex ~height:(multf x scaley) ()))) in consvbox (b::boxs) (res, Q.push c cq) in let rec fct_hist boxs =function |[],_ -> hbox ~pos:`South ~padding:padding (List.rev boxs) |x::res,collist -> let lavbox,listcol = consvbox [] (x,collist) in fct_hist (lavbox::boxs) (res, if cumul then collist else listcol) in let fcth = (fct_hist [] (l,fill)) in let hb = move_hbox cumul cpt scalex fcth in let persp = if perspective then draw_perspect nop (box_perspect scalex hb l) else nop in let labels = match histlabel with | None -> nop | Some lab -> (box_labels lab hb l) in persp ++ Box.draw hb ++ labels ++ (match hlabel with | None -> nop | Some hlab -> (hist_labels hlab hb)) let drawing_parameters width height ?padding nbval valmax nbcol= let padding = match padding with |None -> divf width (4. *. float nbval) |Some i -> i in let scalex = divf (subn width (multf (float ((nbval - 1)/nbcol)) padding)) (float nbval) in let scaley = divf height valmax in scalex, scaley, padding (* Histogramme classique *) let simple ?(width=bp 100.) ?(height=bp 200.) ?padding ?(fill=[lightblue]) ?(perspective=false) ?hcaption ?vcaption ?histlabel ?vlabel ?hlabel l = let histlabel = match histlabel with | None -> None | Some (_, Values) as h -> h | Some (p, User l) -> Some (p, User (List.map (fun x -> [x]) l)) in let valmax = max l in let nbval = List.length l in let scalex, scaley, padding = drawing_parameters width height ?padding nbval valmax 1 in let cq = Q.of_list fill in let l = List.map (fun x -> [x]) l in (hist ~cumul:false width height padding cq perspective scalex scaley ?histlabel ?hlabel 0 l) ++ (laxe ~nbcol:1 padding scalex scaley hcaption vcaption valmax nbval ?vlabel) (* Histogramme de comparaison *) let compare ?(width=bp 100.) ?(height=bp 200.) ?padding ?(fill=[lightblue;red]) ?(perspective=false) ?hcaption ?vcaption ?histlabel ?vlabel ?hlabel l = let nblist = List.length l in let valmax = maxlist l in let nbval = List.fold_left (fun acc x -> (List.length x)+acc) 0 l in let scalex, scaley, padding = drawing_parameters width height ?padding nbval valmax nblist in let rec fct_hist bhlabel c cpt =function |[],_ -> c |x::res,cq -> let col, rescol = Q.pop cq in let x = List.map (fun x -> [x]) x in if (bhlabel) then fct_hist false (c ++ (hist ?hlabel ?histlabel ~cumul:false width height (addn padding (multn (bp ((float_of_int) (nblist-1))) scalex)) (Q.push col Q.empty) perspective scalex scaley cpt x)) (cpt+1) (res, Q.push col rescol) else fct_hist false (c ++ (hist ?histlabel ~cumul:false width height (addn padding (multn (bp ((float_of_int) (nblist-1))) scalex)) (Q.push col Q.empty) perspective scalex scaley cpt x)) (cpt+1) (res, Q.push col rescol) in (fct_hist true nop 0 (l, Q.of_list fill)) ++ (laxe ~nbcol:nblist padding scalex scaley hcaption vcaption valmax nbval ?vlabel) (* Histogramme cumulé *) let stack ?(width=bp 100.) ?(height=bp 200.) ?padding ?(fill=[lightblue;red;green]) ?(perspective=false) ?hcaption ?vcaption ?histlabel ?vlabel ?hlabel l = let nblist = List.length l in let valmax = maxcumul l in let nbval = nblist in let scalex, scaley, padding = drawing_parameters width height ?padding nbval valmax 1 in (hist ~cumul:true width height padding (Q.of_list fill) perspective scalex scaley ?histlabel ?hlabel 0 l) ++ (laxe ~nbcol:1 padding scalex scaley hcaption vcaption valmax nbval ?vlabel) mlpost-0.8.1/dash.ml0000644000443600002640000000254611365367177013501 0ustar kanigdemons(**************************************************************************) (* *) (* 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 (mkF f) let shifted = mkDShifted let pattern = mkDPattern mlpost-0.8.1/helpers.ml0000644000443600002640000000711611365367177014222 0ustar kanigdemons(**************************************************************************) (* *) (* 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 open Point open Num open Box open Command (* puts labels at given points with given text *) let dotlabels ?(pos=`Center) ls lp = seq (List.map2 (fun s p -> dotlabel ~pos:pos (Picture.tex s) p) ls lp) let draw_simple_arrow ?color ?pen ?dashed ?style ?outd ?ind a b = Arrow.simple ?color ?pen ?dashed (Arrow.simple_point_point ?style ?outd ?ind a b) let draw_label_arrow ?color ?pen ?dashed ?style ?outd ?ind ?pos lab a b = let p = Arrow.simple_point_point ?style ?outd ?ind a b in Arrow.simple ?color ?pen ?dashed p ++ label ?pos lab (Path.point 0.5 p) let draw_labelbox_arrow ?color ?pen ?dashed ?style ?outd ?ind ?pos lab a b = draw_label_arrow ?color ?pen ?dashed ?style ?outd ?ind ?pos (Picture.make (Box.draw lab)) a b let box_arrow ?within ?color ?pen ?dashed ?style ?outd ?ind ?sep a b = let a, b = match within with | None -> a,b | Some x -> Box.sub a x, Box.sub b x in Arrow.simple ?color ?pen ?dashed (Box.cpath ?style ?outd ?ind ?sep a b) let box_line ?within ?color ?pen ?dashed ?style ?outd ?ind ?sep a b = let a, b = match within with | None -> a,b | Some x -> Box.sub a x, Box.sub b x in draw ?color ?pen ?dashed (Box.cpath ?style ?outd ?ind ?sep a b) let box_label_line ?within ?color ?pen ?dashed ?style ?outd ?ind ?sep ?pos lab a b = let a, b = match within with | None -> a,b | Some x -> Box.sub a x, Box.sub b x in let p = Box.cpath ?style ?outd ?ind ?sep a b in draw ?color ?pen ?dashed p ++ label ?pos lab (Path.point 0.5 p) let box_label_arrow ?within ?color ?pen ?dashed ?style ?outd ?ind ?sep ?pos lab a b = let a, b = match within with | None -> a,b | Some x -> Box.sub a x, Box.sub b x in let p = Box.cpath ?style ?outd ?ind ?sep a b in Arrow.simple ?color ?pen ?dashed p ++ label ?pos lab (Path.point 0.5 p) (* TODO unify all these functions *) let box_labelbox_arrow ?within ?color ?pen ?dashed ?style ?outd ?ind ?sep ?pos lab a b = box_label_arrow ?within ?color ?pen ?dashed ?style ?outd ?ind ?sep ?pos (Picture.make (Box.draw lab)) a b (*** let hboxjoin ?color ?pen ?dashed ?dx ?dy ?pos ?spacing pl = (* align the pictures in pl, put them in boxes and connect these boxes *) let bl = Box.halign_to_box ?dx ?pos ?spacing pl in match bl with | [] -> nop | hd::tl -> let cmd,_ = List.fold_left (fun (cmd,b1) b2 -> Box.draw b2 ++ box_arrow ?color ?pen ?dashed b1 b2 ++ cmd,b2 ) (Box.draw hd,hd) tl in cmd ***) mlpost-0.8.1/arrow.ml0000644000443600002640000002274411365367177013716 0ustar kanigdemons(**************************************************************************) (* *) (* 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.directionn (Num.multf f (Path.length p)) p let point_on_path f p = Path.pointn (Num.multf 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 (* 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 *) let point_to_point ?kind ?tex ?pos ?anchor ?outd ?ind a b = let r, l = outd, ind in draw ?kind ?tex ?pos ?anchor (Path.pathk [Path.knotp ?r a; Path.knotp ?l b]) 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_point ?kind ?tex ?pos ?anchor ?outd ?ind a b = draw ?kind ?tex ?pos ?anchor (Box.cpath_left ?outd ?ind 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) (*******************************************************************************) (* To be sorted *) (*******************************************************************************) let simple_point_point ?style ?outd ?ind a b = let r,l = outd, ind in 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.1/path.ml0000644000443600002640000001446311365367177013517 0ustar kanigdemons(**************************************************************************) (* *) (* 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 MetaPath open Types include MetaPath.BaseDefs let start x = of_metapath (start x) let append ?style x y = of_metapath (append ?style (of_path x) (of_path y)) type t = Types.path type metapath = Types.metapath let knotp ?(l=defaultdir) ?(r=defaultdir) p = Types.mkKnot l p r let knot ?(l) ?(r) ?(scale) p = knotp ?l (S.p ?scale p) ?r let knotn ?(l) ?(r) p = knotp ?l (S.pt p) ?r let knotlist = List.map (fun (x,y,z) -> Types.mkKnot x y z) let cycle_tmp ?(dir=defaultdir) ?(style=defaultjoint) p = mkPACycle dir style p let cycle = cycle_tmp let concat ?style x y = of_metapath (concat ?style (of_path x) y) (* construct a path with a given style from a knot list *) let pathk ?(style) ?(cycle) l = let p = MetaPath.pathk ?style l in match cycle with | None -> of_metapath p | Some style -> metacycle defaultdir style p let pathp ?(style) ?(cycle) l = pathk ?style ?cycle (List.map (knotp) l) let pathn ?(style) ?(cycle) l = pathp ?style ?cycle (List.map (Point.pt) l) let path ?(style) ?(cycle) ?(scale) l = let sc = S.ptlist ?scale in pathp ?style ?cycle (sc l) (* construct a path with knot list and joint list *) let jointpathk lp lj = of_metapath (MetaPath.jointpathk lp lj) let jointpathp lp lj = jointpathk (List.map (knotp) lp) lj let jointpathn lp lj = jointpathk (List.map knotn lp) lj let jointpath ?(scale) lp lj = jointpathk (List.map (knot ?scale) lp) lj let scale f p = transform [Transform.scaled f] p let rotate f p = transform [Transform.rotated f] p let shift pt p = transform [Transform.shifted pt] p let yscale n p = transform [Transform.yscaled n] p let xscale n p = transform [Transform.xscaled n] p let strip n p = let p0 = point 0. p in let p1 = pointn (length p) p in let c = scale n fullcircle in cut_after (shift p1 c) (cut_before (shift p0 c) p) (* directed paths *) type orientation = | Up | Down | Left | Right | Upn of Num.t | Downn of Num.t | Leftn of Num.t | Rightn of Num.t let divise_dir l = let rec fct left_down right_up listn =function |[] -> left_down,right_up,listn |((Leftn _|Rightn _|Downn _|Upn _) as x) ::res -> fct left_down right_up (x::listn) res |((Left|Down) as x) ::res -> fct (x::left_down) right_up listn res |((Right|Up) as x) ::res -> fct left_down (x::right_up) listn res in fct [] [] [] l open Num open Num.Infix open Point let dist_horizontal dirlist abs distance = let left,right,listn = divise_dir dirlist in let diff = (List.length right) - (List.length left) in let distance = gmean distance zero in let d = List.fold_left (fun a x -> match x with |Leftn n -> (-/) a n |Rightn n -> (+/) a n |_ -> failwith "impossible") distance listn in let dist,b = if diff = 0 then (bp 10.),false else (gmean ((/./) d (float diff)) zero),true in let rec fct acc abs = function |[] -> List.rev acc |Left::res -> let abs = (-/) abs dist in fct (abs::acc) abs res |Leftn n::res -> let abs = (-/) abs n in fct (abs::acc) abs res |Right::res -> let abs = (+/) abs dist in fct (abs::acc) abs res |Rightn n::res -> let abs = (+/) abs n in fct (abs::acc) abs res |_ -> failwith "impossible" in fct [] abs dirlist let dist_vertical dirlist ordo distance = let down,up,listn = divise_dir dirlist in let diff = (List.length up) - (List.length down) in let d = List.fold_left (fun a x -> match x with |Downn n -> (-/) a n |Upn n -> (+/) a n |_ -> failwith "impossible") distance listn in let dist,b = if diff = 0 then (bp 10.),false else (gmean ((/./) d (float diff)) zero),true in let rec fct acc ordo = function |[] -> List.rev acc |Down::res -> let ordo = (-/) ordo dist in fct (ordo::acc) ordo res |Downn n::res -> let ordo = (-/) ordo n in fct (ordo::acc) ordo res |Up::res -> let ordo = (+/) ordo dist in fct (ordo::acc) ordo res |Upn n::res -> let ordo = (+/) ordo n in fct (ordo::acc) ordo res |_ -> failwith "impossible" in fct [] ordo dirlist let smart_path ?style dirlist p1 p2 = let width = (-/) (xpart p2) (xpart p1) in let height = (-/) (ypart p2) (ypart p1) in let dirhorizontal, dirvertical = List.partition (fun x -> match x with |(Left|Right|Leftn _|Rightn _) -> true |_->false) dirlist in let lesdisth = dist_horizontal dirhorizontal (xpart p1) width in let lesdistv = dist_vertical dirvertical (ypart p1) height in let rec fct pc acc dirl dv dh = match dirl,dv,dh with |(Up|Upn _|Down|Downn _)::dres, dv::dvres, dhlist -> let ps = pt (xpart pc, dv) in fct ps (ps::acc) dres dvres dhlist |(Left|Leftn _|Right|Rightn _)::dres, dvlist, dh::dhres -> let ps = pt (dh, (ypart pc)) in fct ps (ps::acc) dres dvlist dhres |[],_, _ -> List.rev (p2::acc) |_ -> assert false in let points = fct p1 [p1] dirlist lesdistv lesdisth in pathp ?style points 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) mlpost-0.8.1/latex/0000755000443600002640000000000011365367167013335 5ustar kanigdemonsmlpost-0.8.1/latex/supp-mpe_mod.tex0000644000443600002640000001670611365367177016477 0ustar kanigdemons%Modification of supp-mpe.tex to allow the indirect transformation of % an image %This trick use a square which replace the image in the metapost computation. %mp-spec must be modified: % addto p contour unitsquare scaled 0 ; % is replaced by : % addto p contour unitsquare transformed t ; \unprotect %Accept more than one insertion of the same image \defineMPspecial{10} {\setxvalue{mps:gr:\gMPs8}% {\noexpand\handleMPfigurespecial {\gMPs1}{\gMPs2}{\gMPs3}{\gMPs4}{\gMPs5}{\gMPs6}{\gMPs7}% % \noexpand\setxvalue{mps:gr:\gMPs8}{} }} % \Specialstrigimage isn't 0 only if we parse the square which % replace an image. \newcount{\Specialstrigimage} \Specialstrigimage=0 % The affine part of the matrix of transformation \def\Specialsmataa{}\def\Specialsmatab{}\def\Specialsmatac{} \def\Specialsmatba{}\def\Specialsmatbb{}\def\Specialsmatbc{} % The filename of the current image \def\Specialsfile{} % An usual trick from trig.sty which remove the unit of a dimen {\catcode`t=12\catcode`p=12\gdef\noPT#1pt{#1}} \def\Specialsrempt#1{\expandafter\noPT\the#1\space} % Extract from the path of the square the correct information, ie the % corner of the square % Twice the same function because I 'm not a good tex programmer. \newdimen{\specialstmp} \newdimen{\specialsdumb} \def\SpecialsgetnormalMPsegmenta { \ifcase\getMPkeyword\relax %\PDFcode{\!MPgMPs1 \!MPgMPs2 l}% \edef\myx{\!MPgMPs1} \edef\myy{\!MPgMPs2} \or %\PDFcode{\!MPgMPs1 \!MPgMPs2 \!MPgMPs3 \!MPgMPs4 \!MPgMPs5 \!MPgMPs6 c}% \edef\myx{\!MPgMPs5} \edef\myy{\!MPgMPs6} \or %\PDFcode{\!MP\lastMPmoveX\space\!MP\lastMPmoveY\space l}% \edef\myx{\!MPgMPs5} \edef\myy{\!MPgMPs6} \or %\edef\lastMPmoveX{\gMPs1}% evt \!MP here %\edef\lastMPmoveY{\gMPs2}% %\PDFcode{\!MP\lastMPmoveX\space \!MP\lastMPmoveY\space m}% \fi \specialstmp=\Specialsmatac pt \multiply\specialstmp by -1 \specialsdumb=\myx pt \advance\specialstmp by \specialsdumb \global\edef\Specialsmataa{\Specialsrempt\specialstmp} \specialstmp=\Specialsmatbc pt \multiply\specialstmp by -1 \specialsdumb=\myy pt \advance\specialstmp by \specialsdumb \global\edef\Specialsmatba{\Specialsrempt\specialstmp} } \def\SpecialsgetnormalMPsegmentb { \ifcase\getMPkeyword\relax %\PDFcode{\!MPgMPs1 \!MPgMPs2 l}% \edef\myx{\!MPgMPs1} \edef\myy{\!MPgMPs2} \or %\PDFcode{\!MPgMPs1 \!MPgMPs2 \!MPgMPs3 \!MPgMPs4 \!MPgMPs5 \!MPgMPs6 c}% \edef\myx{\!MPgMPs5} \edef\myy{\!MPgMPs6} \or %\PDFcode{\!MP\lastMPmoveX\space\!MP\lastMPmoveY\space l}% \edef\myx{\!MPgMPs5} \edef\myy{\!MPgMPs6} \or %\edef\lastMPmoveX{\gMPs1}% evt \!MP here %\edef\lastMPmoveY{\gMPs2}% %\PDFcode{\!MP\lastMPmoveX\space \!MP\lastMPmoveY\space m}% \fi \specialstmp=\Specialsmatac pt \multiply\specialstmp by -1 \specialsdumb=\myx pt \advance\specialstmp by \specialsdumb \global\edef\Specialsmatab{\Specialsrempt\specialstmp} \specialstmp=\Specialsmatbc pt \multiply\specialstmp by -1 \specialsdumb=\myy pt \advance\specialstmp by \specialsdumb \global\edef\Specialsmatbb{\Specialsrempt\specialstmp} } % Replace the true output function by a filter. It replace the square % by the corresponding image \let\normalPDFcode\PDFcode %%\def\normalPDFcode#1{\donormalPDFcode{#1}} %%\def\PDFcode#1{ % Extract the information from the path %% \ifcase\Specialstrigimage %% % Usually do nothing %% \or %The first move is exactly the translation %% %part of the translation %% \global\edef\Specialsmatac{\gMPs1} %% \global\edef\Specialsmatbc{\gMPs2} %% \or %The second point is the first column of the matrix minus %% %the translation %% \SpecialsgetnormalMPsegmenta %% \or %The Third give only redondant informations %% \or %The second point is the second column of the matrix minus %% %the translation %% \SpecialsgetnormalMPsegmentb %% \else %Sometimes the first point %% \fi % Output the information %% \ifnum\Specialstrigimage=0\relax % Usually the function do nothing %% \normalPDFcode{#1}% %% \else %% % During the parsing of the square : %% \if f#1 %% % The fill instruction is the end of the path %% \global\Specialstrigimage=0 %% % We output the transformation %% \normalPDFcode{q \Specialsmataa\space\Specialsmatba\space\Specialsmatab\space\Specialsmatbb\space\Specialsmatac\space\Specialsmatbc\space cm}% %% % I don't know why this translation is now needed... %% \normalPDFcode{q 1 0 0 1 0 1 cm}% %% \rlap{\getvalue\Specialsfile}% %% \normalPDFcode{Q}% %% \normalPDFcode{Q}% %% \else %% %Otherwise we look for the next point of the path %% \global\advance\Specialstrigimage by \plusone %% \fi %% \fi %%} \let\normalfinishMPpath\finishMPpath \def\finishMPpath { \ifnum\Specialstrigimage=0\relax \normalfinishMPpath \else \global\Specialstrigimage=0 %\global\let\PDFcode\normalPDFcode % We output the transformation \PDFcode{q \Specialsmataa\space\Specialsmatba\space\Specialsmatab\space\Specialsmatbb\space\Specialsmatac\space\Specialsmatbc\space cm}% % I don't know why this translation is now needed... \PDFcode{q 1 0 0 1 0 1 cm}% \rlap{\getvalue\Specialsfile}% \PDFcode{Q}% \PDFcode{Q}% \fi } \let\normalflushnormalMPsegment\flushnormalMPsegment \def\flushnormalMPsegment { %Extract the information from the path \ifcase\Specialstrigimage \or %The first move is exactly the translation %part of the translation \global\edef\Specialsmatac{\gMPs1} \global\edef\Specialsmatbc{\gMPs2} \or %The second point is the first column of the matrix minus %the translation \SpecialsgetnormalMPsegmenta \or %The Third give only redondant informations \or %The second point is the second column of the matrix minus %the translation \SpecialsgetnormalMPsegmentb \else %Sometimes the first point \fi \ifnum\Specialstrigimage=0\relax \normalflushnormalMPsegment \else \global\advance\Specialstrigimage by \plusone \fi } \def\vide#1{} \def\handleMPfigurespecial#1#2#3#4#5#6#7% todo : combine with ext fig {\vbox to \zeropoint {\vss \hbox to \zeropoint {\ifcase\pdfoutput\or % will be hooked into the special driver \doiffileelse{#7} {\doifundefinedelse{mps:x:#7} {\immediate\pdfximage\!!width\onebasepoint\!!height\onebasepoint{#7}% \setxvalue{mps:x:#7}{\pdfrefximage\the\pdflastximage}\message{[not reusing]}}% {\message{[reusing figure #7]}}% %We save the filename of the current image \global\edef\Specialsfile{mps:x:#7}% %\PDFcode{q #1 #2 #3 #4 #5 #6 cm}% %\rlap{\getvalue\Specialsfile}% %\PDFcode{Q}% %And we start the parsing of the square \global\Specialstrigimage=1 \global\let\closeMPpath\relax } {\message{[unknown figure #7]}}% \fi \hss}}} \protect \endinput mlpost-0.8.1/latex/beamer_mlpost.sty0000644000443600002640000000013511365367177016727 0ustar kanigdemons\newcommand<>{\includesomegraphics}[2][]{\includegraphics#3[#1]{#2\the\beamer@slideinframe}} mlpost-0.8.1/latex/README0000644000443600002640000000040711365367177014217 0ustar kanigdemonsIf you want to include external images in a figure, you need to put the *.sty and *.tex files at a place that is visible for latex/pdflatex, and you have to include the following lines in your LaTeX file: \usepackage{specials} \LoadMetaPostSpecialExtensions mlpost-0.8.1/latex/specials.sty0000644000443600002640000000230311365367177015700 0ustar kanigdemons% This file % Adds support for extended MetaPost features (transparency) \def\LoadMetaPostSpecialExtensions{% \AtBeginDocument{% \edef\@tempa{% \catcode`\noexpand\=\the\catcode`\= % \catcode`\noexpand\!\the\catcode`\! % \catcode`\noexpand\@\the\catcode`\@ % \catcode`\noexpand\?\the\catcode`\? % }% \@makeother\=% \IfFileExists{supp-pdf}{% \IfFileExists{supp-mis}{% \IfFileExists{supp-mpe}{% \input{supp-mis}% \input{supp-mpe}% \input{supp-mpe_mod}% \MPcmykcolorstrue \MPspotcolorstrue \chardef\makeMPintoPDFobject=1 % }{% \GPT@warn{% Cannot enable MetaPost Special Extensions,\MessageBreak because supp-mpe.tex is missing% }% }% }{% \GPT@warn{% Cannot enable MetaPost Special Extensions,\MessageBreak because supp-mis.tex is missing% }% }% }{% \GPT@warn{% Cannot enable support for MetaPost images,\MessageBreak because supp-pdf.tex is missing% }% }% \@tempa }% } \ifx\@onlypreamble\@undefined \else \@onlypreamble\LoadMetaPostSpecialExtensions \fi mlpost-0.8.1/mlpost_options.ml0000644000443600002640000000707311365367177015653 0ustar kanigdemons(**************************************************************************) (* *) (* 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 Mlpost_desc_options let call_cmd = Misc.call_cmd let () = let user_opts = Queue.create () in let user_opt = ("--", Arg.Rest (fun s -> Queue.add s user_opts), "The option given to the program") in Arg.parse (Arg.align (user_opt::spec)) (fun s -> raise (Arg.Bad "No anonymous option among the mlpost options, \ begin by -- for the user options")) "A program compiled with mlpost"; (* Replace the mlpost argument by the user one *) for i = 1 to (Array.length Sys.argv) - 1 do if Queue.is_empty user_opts then Sys.argv.(i) <- "" else Sys.argv.(i) <- Queue.pop user_opts done; (* And reset the current of Arg *) Arg.current := 0; let prelude = match !latex_file with | None -> None | Some f -> Some (Metapost_tool.read_prelude_from_tex_file f) in let verbose = !verbose in Metapost.set_filename_prefix !filename_prefix; Command.set_verbosity verbose; Concrete.set_t1disasm !t1disasm; Concrete.set_prelude2 prelude; let bn = Filename.concat (Sys.getcwd ()) (Filename.basename (Sys.argv.(0))) in let do_at_exit () = if !cairo then begin if not !xpdf then if !png then Cairost.dump_png () else if !svg then Cairost.dump_svg () else if !pdf then Cairost.dump_pdf () else Cairost.dump_ps () else Cairost.dump_pdfs "_mlpost" end else begin if !mp && not !xpdf then Metapost.dump_mp ?prelude bn else if !png && not !xpdf then Metapost.dump_png ?prelude ~verbose ~clean:(not !dont_clean) bn else Metapost.dump ?prelude ~pdf:!pdf ~eps:!eps ~verbose ~clean:(not !dont_clean) bn; if !xpdf then begin Metapost.dump_tex ?prelude "_mlpost"; begin try Sys.remove "_mlpost.aux" with _ -> () end; ignore (call_cmd ~verbose "pdflatex _mlpost.tex"); end end; if !xpdf then begin (* ignore (Misc.call_cmd ~verbose "setsid xpdf -remote mlpost _mlpost.pdf &") *) if fst (call_cmd ~verbose "fuser _mlpost.pdf") = 0 then ignore (call_cmd ~verbose "xpdf -remote mlpost -reload") else ignore (call_cmd ~verbose "setsid xpdf -remote mlpost _mlpost.pdf &") end in (* When an exit is fired inside do_at_exit the function seems to be run again *) let done_once = ref false in at_exit (fun () -> if not !done_once then (done_once := true; do_at_exit ())) mlpost-0.8.1/hashcons.mli0000644000443600002640000000745011365367177014540 0ustar kanigdemons(**************************************************************************) (* *) (* 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. *) (* *) (**************************************************************************) (* * hashcons: hash tables for hash consing * Copyright (C) 2000 Jean-Christophe FILLIATRE * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Library General Public * License version 2, as published by the Free Software Foundation. * * 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 Library General Public License version 2 for more details * (enclosed in the file LGPL). *) (*s Hash tables for hash consing. Hash consed values are of the following type [hash_consed]. The field [tag] contains a unique integer (for values hash consed with the same table). The field [hkey] contains the hash key of the value (without modulo) for possible use in other hash tables (and internally when hash consing tables are resized). The field [node] contains the value itself. Hash consing tables are using weak pointers, so that values that are no more referenced from anywhere else can be erased by the GC. *) type 'a hash_consed = private { hkey : int; tag : int; node : 'a } (*s Generic part, using ocaml generic equality and hash function. *) type 'a t val create : int -> 'a t (** [create n] creates an empty table of initial size [n]. The table will grow as needed. *) val clear : 'a t -> unit (** Removes all elements from the table. *) val hashcons : 'a t -> 'a -> 'a hash_consed (** [hashcons t n] hash-cons the value [n] using table [t] i.e. returns any existing value in [t] equal to [n], if any; otherwise, allocates a new one hash-consed value of node [n] and returns it. As a consequence the returned value is physically equal to any equal value already hash-consed using table [t]. *) val iter : ('a hash_consed -> unit) -> 'a t -> unit (** [iter f t] iterates [f] over all elements of [t]. *) val stats : 'a t -> int * int * int * int * int * int (** Return statistics on the table. The numbers are, in order: table length, number of entries, sum of bucket lengths, smallest bucket length, median bucket length, biggest bucket length. *) (*s Functorial interface. *) module type HashedType = sig type t val equal : t -> t -> bool val hash : t -> int end module type S = sig type key type t val create : int -> t val clear : t -> unit val hashcons : t -> key -> key hash_consed val iter : (key hash_consed -> unit) -> t -> unit val stats : t -> int * int * int * int * int * int end module Make(H : HashedType) : (S with type key = H.t) mlpost-0.8.1/backend-test.ml0000644000443600002640000005156611365367177015134 0ustar kanigdemons(**************************************************************************) (* *) (* 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.1/real_plot.ml0000644000443600002640000002030411365367177014533 0ustar kanigdemons(**************************************************************************) (* *) (* 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 C = Command module P = Picture type ('a,'b) node = { values : 'b; node : 'a} type 'a curve = ('a,(float -> float option) list) node type 'a graph = 'a curve list let curve_l fl node = { values = fl; node = node} let curve_opt f node = curve_l [f] node let curve f node = curve_opt (fun x -> Some (f x)) node let graph x = x let rec calc_one_value nb_f ((which_f,acc) as w_acc) x = function | [] -> (nb_f,None::acc) | f::lf -> match f x with | None -> calc_one_value (nb_f+1) w_acc x lf | Some y -> if which_f = nb_f then (nb_f,Some (x,y)::acc) else (nb_f,Some (x,y)::None::acc) let calc xmin xmax pitch {values=cf;node=node} = let rec aux acc = function | x when x<=xmin -> calc_one_value 0 acc xmin cf | x -> aux (calc_one_value 0 acc x cf) (x-.pitch) in {values=snd (aux (0,[]) xmax);node=node} open MetaPath let cons_opt x l = match x with None -> l | Some x -> (to_path x)::l let rec pathn_opt acc current = function | [] -> cons_opt current acc | v::l -> match v,current with | None, _ -> pathn_opt (cons_opt current acc) None l | Some v, None -> pathn_opt acc (Some (start (knotn v))) l | Some v, Some c -> pathn_opt acc (Some (concat ~style:jLine c (knotn v))) l let draw_aux ?label values = C.seq ( List.map (fun (values,brush) -> let line = pathn_opt [] None values in C.seq (List.map (Path.draw ~brush) line)) values) open Num let ysep = 10 let rec tick pitch xmax nb = let rec aux acc x = function | n when n <= 0 -> acc | n -> aux (x::acc) (x-.pitch) (n-1) in aux [] xmax nb let rec tick_log xmax = let rec aux acc = function | x when x > xmax -> acc | x -> aux (x::acc) (x*.10.) in aux [] 1. let rec tick_logneg xmin = let rec aux acc = function | x when x < xmin -> acc | x -> aux (x::acc) (x*.10.) in aux [] (-.1.) let vtick = let t = Point.bpp (2.5,0.) in fun v -> (Point.sub v t, Point.add v t) let draw_axes ~logarithmic ~ytick ~xmin ~xmax ~ymin ~ymax ~yzero ~xzero ~pitch = let ytick = C.seq ytick in let vert = Arrow.simple (Path.pathn ~style:Path.jLine [xzero,ymin;xzero,ymax]) in let hori = Arrow.simple (Path.pathn ~style:Path.jLine [xmin,yzero;xmax,yzero]) in C.seq [ytick;vert;hori] let count_max iter = let y = ref neg_infinity in iter (fun x -> y := max !y x); !y let count_min iter = let y = ref infinity in iter (fun x -> y := min !y x); !y let filter_opt f l = {l with values = List.map (function | Some (x,y) as p when f y -> p | _ -> None) l.values} let draw ?(logarithmic=false) ?curve_brush ?label ?ymin ?ymax ~xmin ~xmax ~pitch ~width ~height graph = let values = List.map (calc xmin xmax pitch) graph in (* ymin, ymax calculation *) let values = match ymin,ymax with | None,None -> values | _ -> let f = match ymin,ymax with | None,None -> assert false | Some ymin, None -> (fun f -> f >= ymin) | Some ymin, Some ymax -> (fun f -> f >= ymin && f <= ymax) | None, Some ymax -> (fun f -> f <= ymax) in List.map (filter_opt f) values in let yvalues = (fun f -> List.iter (fun x -> List.iter (function Some (_,y) -> f y| None -> ()) x.values) values) in let ymax = match ymax with None -> count_max yvalues | Some ymax -> ymax in (*let ymax = if ymax = 0. then 1. else ymax in *) let ymin = match ymin with None -> count_min yvalues | Some ymin -> ymin in (*let ymin = if ymin = 0. then -.1. else ymin in *) let ymax = if ymin=ymax then ymin +. 1. else ymax in (* scale *) let conv = if logarithmic then fun v -> if abs_float v < 1. then v else ((log10 (abs_float v)) +. 1.) *. (v/.(abs_float v)) else fun v -> v in let scaley = Num.divn height (Num.bp ((conv ymax)-. (conv ymin))) in let scalex = Num.divn width (Num.bp (xmax-.xmin)) in let scalex x = Num.multn (Num.bp (x-.xmin)) scalex in let scaley y = Num.multn (Num.bp ((conv y)-.(conv ymin))) scaley in let scale (x,y) = scalex x,scaley y in let scale_opt = function | Some (x,y) -> Some (scale (x,y)) | None -> None in let xzero,yzero = scale (0.,0.) in (* tick vertical *) let ymm = ymax -. ymin in (*let xmm = xmax -. xmin in*) let ypitchl = if logarithmic then let l1 = tick_log ymax in let l2 = tick_logneg ymin in l1@l2 else let ypitch = 10.**(floor (log10 (ymm/.(float ysep)))) in let ymax2 = ypitch *. (floor (ymax/.ypitch)) in let ysep = int_of_float (ymm/.ypitch) in tick ypitch ymax2 ysep in let ypitchl = ymin::ypitchl@[ymax] in (* Remove the tick which are too close but we need concrete for that... Currently only for ex, but we can be more precise *) let ypitchl = if not Concrete.supported then List.map (fun y -> (y,scaley y)) ypitchl else let ex2 = 2. *. Concrete.float_of_num Num.ex_factor in let _, ypitchl = List.fold_left (fun (last,acc) y -> let yn = scaley y in let f = Concrete.float_of_num yn in if abs_float (last -. f) > ex2 then (f,(y,yn)::acc) else (last,acc)) (infinity,[]) ypitchl in ypitchl in let zero = scalex 0. in let ytick = List.map (fun (y,yn) -> let p = Point.pt (zero,yn) in let (p1,p2) = (vtick p) in let label = Format.sprintf "{%2.1f}" y in C.seq [ C.label ~pos:`West (Picture.tex label) p1; Path.draw (Path.pathp ~style:Path.jLine [p1;p2])]) ypitchl in (* values *) let values = List.map (fun x -> {x with values = List.map scale_opt x.values} ) values in (* Brush and legend *) let color = Color.color_gen 1. 1. in let curve_brush _ = Brush.t () in let colors = List.map (fun x -> let b = curve_brush x.node in let b,c = match Brush.color b with | Some c -> b,c | None -> let c = color () in Brush.t ~color:c ~brush:b (),c in (b,c,x)) values in let legend = match label with | None -> C.nop | Some label -> let legend = Legend.legend (List.map (fun (_,c,x) -> (c,label x.node)) colors) in C.label ~pos:`East legend (Point.pt (scale (xmax,(ymax+.ymin)/.2.))) in let values = List.map (fun (b,_,x) -> (x.values,b)) colors in let xmin,ymin = scale (xmin,ymin) in let xmax,ymax = scale (xmax,ymax) in let axes = draw_axes ~logarithmic ~ytick ~xmin ~xmax ~ymin ~ymax ~yzero ~xzero ~pitch in C.seq [axes; draw_aux ?label values; legend] mlpost-0.8.1/cairost.ml0000644000443600002640000000714311365367177014224 0ustar kanigdemons(**************************************************************************) (* *) (* 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 open Icairost let set_verbosity = set_verbosity let () = Types.add_set_verbosity set_verbosity 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 = (fname^".pdf") in try emit_pdf pdfname fig with | Cairo.Error status -> Format.printf "An@ internal@ error@ occured@ during@ the generation@ of@ %s@ with@ Cairo :@ %s@." pdfname (Cairo.string_of_status status) | error -> Format.printf "An@ internal@ error@ occured@ during@ the@ generation@ of@ %s :@ %s@." pdfname (Printexc.to_string error) ) Metapost.figures let dump_pdfs fname = let figs = List.rev (Queue.fold (fun l (_,_,x) -> x::l) [] Metapost.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_ps () = Queue.iter (fun (_,fname,fig) -> emit_ps (fname^".ps") fig) Metapost.figures let dump_png () = Queue.iter (fun (_,fname,fig) -> emit_png (fname^".png") fig) Metapost.figures let dump_svg () = Queue.iter (fun (_,fname,fig) -> emit_svg (fname^".svg") fig) Metapost.figures ELSE let supported = false let set_verbosity _ = failwith "Cairost.set_verbosity : not supported" 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 set_prelude _ = failwith "Cairost.set_prelude : not supported" let set_t1disasm _ = failwith "Cairost.set_t1disasm : 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.1/tool.ml0000644000443600002640000002163511365367177013537 0ustar kanigdemons(**************************************************************************) (* *) (* 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 Arg let use_ocamlbuild = ref false let ccopt = ref " " let execopt = ref " " let verbose = Mlpost_desc_options.verbose let native = ref false let libraries = ref (Version.libraries Version.libdir) let compile_name = ref None let dont_execute = ref false let dont_clean = ref false let add_nothing = ref false let files = Queue.create () let not_cairo = Version.not_cairo let not_bitstring = Version.not_bitstring let used_libs = (* put libraries in correct order here *) let acc = ["unix"] in let acc = if not_cairo then acc else "cairo"::acc in let acc = if not_bitstring then acc else "bitstring"::acc in let acc = "mlpost"::acc in (* mlpost_options is activated by default *) let acc = "mlpost_options"::acc in ref acc let add_contrib x = if List.mem_assoc x !libraries then used_libs := x::!used_libs else begin Format.eprintf "contrib %s unknown" x; exit 1 end let remove_mlpost_options () = used_libs := List.filter (fun s -> s <> "mlpost_options") !used_libs let add_file f = if not (Filename.check_suffix f ".ml") then begin eprintf "mlpost: don't know what to do with %s@." f; exit 1 end; if not (Sys.file_exists f) then begin eprintf "mlpost: %s: no such file@." f; exit 1 end; Queue.add f files let version () = (* The first line of the output should be the version number, and only the * version number! *) Format.printf "%s@." Version.version; Format.printf "mlpost %s compiled at %s@." Version.version Version.date; Format.printf "searching for mlpost.cm(a|xa) in %s@." Version.libdir; if not not_cairo || not not_bitstring then Format.printf "additional directories are %s@." Version.include_string; exit 0 let add_ccopt x = ccopt := !ccopt ^ x ^ " " let add_execopt x = execopt := !execopt ^ x ^ " " let add_libdir libdir = libraries := Version.libraries libdir let give_lib () = List.fold_left (fun (acc1,acc2) x -> let includes_,libs = List.assoc x !libraries in List.rev_append includes_ acc1, List.rev_append libs acc2) ([],[]) !used_libs let get_include_compile s = (* TODO revoir *) let aux = function (* | "cmxa" -> List.map (fun (x,y) -> Filename.concat x (y^".cmxa")) (give_lib ()) | "cma" -> List.map (fun (x,y) -> Filename.concat x (y^".cma")) (give_lib ()) *) | "dir" -> fst (give_lib ()) | "file" -> snd (give_lib ()) | _ -> assert false in print_string (String.concat "\n" (aux s)) let nocairo () = print_string "Mlpost has not been compiled with cairo\n"; exit 1 let options_for_compiled_prog = Queue.create () let aotofcp ?arg s = Queue.add s options_for_compiled_prog; match arg with | None -> () | Some s -> Queue.add s options_for_compiled_prog let execopt cmd = let b = Buffer.create 30 in bprintf b "%s %a -- %s@?" cmd (fun fmt -> Queue.iter (fprintf fmt "\"%s\" ")) options_for_compiled_prog !execopt; Buffer.contents b let build_args ?ext () = (* ext = None => ocamlbuild *) let lib_ext lib acc = match ext with | None -> "-lib"::lib::acc | Some ext -> (lib^ext)::acc in let include_ acc libdir = match ext with | None -> (sprintf "-cflags -I,%s -lflags -I,%s " libdir libdir)::acc | Some ext -> "-I"::libdir::acc in List.fold_left (fun acc c -> let llibdir,llib = List.assoc c !libraries in let acc = List.fold_right lib_ext llib acc in let acc = List.fold_left include_ acc llibdir in acc) [] !used_libs (* The option have the same behavior but add itself to option_for_compiled_prog in addition *) let wrap_option (opt,desc,help) = let desc = match desc with | Unit f -> Unit (fun () -> f ();aotofcp opt) | Set s -> Unit (fun () -> s:=true; aotofcp opt) | Clear s -> Unit (fun () -> s:=false; aotofcp opt) | String f -> String (fun s -> f s;aotofcp ~arg:s opt) | Int f -> Int (fun s -> f s;aotofcp ~arg:(string_of_int s) opt) | Float f -> Float (fun s -> f s;aotofcp ~arg:(string_of_float s) opt) | Bool f -> Bool (fun s -> f s;aotofcp ~arg:(string_of_bool s) opt) | Set_int s -> Int (fun x -> s:=x; aotofcp ~arg:(string_of_int x) opt) | Set_float s -> Float (fun x -> s:=x; aotofcp ~arg:(string_of_float x) opt) | Set_string s -> String (fun x -> s:=x; aotofcp ~arg:x opt) | Symbol (l, f) -> Symbol (l,fun x -> f x; aotofcp ~arg:x opt) | Rest _ | Tuple _ -> assert false (*Not implemented... *) in (opt,desc,help) let spec = Arg.align (["-ocamlbuild", Set use_ocamlbuild, " Use ocamlbuild to compile"; "-native", Set native, " Compile to native code"; "-ccopt", String add_ccopt, "\"\" Pass to the Ocaml compiler"; "-execopt", String add_execopt, "\"\" Pass to the compiled program"; "-version", Unit version, " Print Mlpost version and exit"; "-libdir", String add_libdir, " change assumed libdir of mlpost"; "-get-include-compile", Symbol (["cmxa";"cma";"dir";"file"],get_include_compile), " Output the libraries which are needed by the library Mlpost"; "-compile-name", String (fun s -> compile_name := Some s), " Keep the compiled version of the .ml file"; "-dont-execute", Set dont_execute, " Don't execute the mlfile"; "-no-magic", Unit remove_mlpost_options, " Do not parse mlpost options, do not call Metapost.dump"; "-contrib", String add_contrib, " Compile with the specified contrib" ]@(if not_cairo then ["-cairo" , Unit nocairo, " Mlpost has not been compiled with the cairo backend"; "-t1disasm" , Unit nocairo, " Mlpost has not been compiled with the cairo backend"; ] else []) @(List.map wrap_option Mlpost_desc_options.spec)) let () = Arg.parse spec add_file "Usage: mlpost [options] files..." exception Command_failed of int let command' ?inv ?outv s = let s, _ = Misc.call_cmd ?inv ?outv ~verbose:!verbose s in if s <> 0 then raise (Command_failed s) let command ?inv ?outv s = try command' ?inv ?outv s with Command_failed s -> exit s let execute ?outv cmd = let cmd = execopt cmd in if !dont_execute then (if !verbose then printf "You can execute the program with :@.%s" cmd) else command ?outv cmd let normalize_filename s = if Filename.is_relative s then "./"^s else s let get_exec_name compile_name = match compile_name with | None -> Filename.temp_file "mlpost" "" | Some s -> normalize_filename s let try_remove s = try Sys.remove s with _ -> () let ocaml_generic compiler args = let s = get_exec_name !compile_name in let cmd = compiler ^ " -o " ^ s ^ " " ^ String.concat " " args in command ~outv:true cmd; execute ~outv:true s; match !compile_name with | None -> if !dont_clean then () else Sys.remove s | Some s -> () let ocaml = ocaml_generic Version.ocamlc let ocamlopt = ocaml_generic Version.ocamlopt let ocamlbuild args exec_name = let args = if !verbose then "-classic-display" :: args else " -quiet"::args in command ~outv:true ("ocamlbuild " ^ String.concat " " args ^ exec_name); execute ~outv:true ("_build/"^exec_name); (match !compile_name with | None -> () | Some s -> command ("cp _build/" ^ exec_name ^ " " ^ s)); if !dont_clean then () else command "ocamlbuild -clean" let compile f = let bn = Filename.chop_extension f in if !use_ocamlbuild then let ext = if !native then ".native" else ".byte" in let exec_name = bn ^ ext in try ocamlbuild (build_args () @ ["-no-links";!ccopt]) exec_name with Command_failed out -> exit out else let ext = if !native then ".cmxa" else ".cma" in let args = build_args ~ext () @ [!ccopt; f] in if !native then ocamlopt args else ocaml args; if not !dont_clean then List.iter (fun suf -> try_remove (bn^suf)) [".cmi";".cmo";".cmx";".o"] let () = Queue.iter compile files mlpost-0.8.1/FAQ0000644000443600002640000000321311365367177012552 0ustar kanigdemonsFrequently 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.1/num.ml0000644000443600002640000000737611365367177013367 0ustar kanigdemons(**************************************************************************) (* *) (* 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 type t = num let zero = mkF 0. let one = mkF 1. let minus_one = mkF (-.1.) let two = mkF 2. let of_float = mkF let num_of_int i = mkF (float_of_int i) let bp f = mkF f let pt f = mkF (0.99626 *. f) let cm f = mkF (28.34645 *. f) let mm f = mkF (2.83464 *. f) let inch f = mkF (72. *. f) let pi = 3.1415926535897932384626433832795029 let pi_div_180 = pi /. 180.0 let deg2rad f = pi_div_180 *. f let is_zero f = abs_float f < 0.0001 type scale = float -> t let addn x y = match x.node, y.node with | F f1, F f2 -> mkF (f1 +. f2) | _, F f when is_zero f -> x | F f, _ when is_zero f -> y | _, _ -> mkNAdd x y let subn x y = match x.node, y.node with | F f1, F f2 -> mkF (f1 -. f2) | _, F f when is_zero f -> x | _, _ -> mkNSub x y let multn x y = match x.node, y.node with | F f1, F f2 -> mkF (f1 *. f2) | (F f, _ | _ , F f) when is_zero f -> zero | _, _ -> mkNMult x y let multf f x = multn (mkF f) x let divn x y = match x.node, y.node with | F f1, F f2 -> mkF (f1 /. f2) | F f, _ when is_zero f -> zero | _, _ -> mkNDiv x y let divf x f = divn x (mkF f) let maxn x y = match x.node, y.node with | F f1, F f2 -> mkF (max f1 f2) | _, _ -> mkNMax x y let minn x y = match x.node, y.node with | F f1, F f2 -> mkF (min f1 f2) | _, _ -> mkNMin x y let gmean x y = match x.node, y.node with | F f1, F f2 -> mkF ( sqrt (f1 *. f1 +. f2 *. f2 )) | _, F f when is_zero f -> x | F f, _ when is_zero f -> y | _, _ -> mkNGMean x y let fold_max f = List.fold_left (fun w p -> maxn w (f p)) let if_null n n1 n2 = match n.node with | F f when is_zero f -> n1 | F f -> n2 | _ -> mkNIfnullthenelse n n1 n2 (* let bpn n = n let ptn n = multn (F 0.99626) n let cmn n = multn (F 28.34645) n let mmn n = multn (F 2.83464) n let inchn n = multn (F 72.) n *) module Scale = struct let bp x y = bp (x *. y) let pt x y = pt (x *. y) let cm x y = cm (x *. y) let mm x y = mm (x *. y) let inch x y = inch (x *. y) end module Infix = struct let (+/) = addn let (-/) = subn let ( */) = multn let (//) = divn let ( *./) = multf let (/./) = divf end open Infix let neg x = zero -/ x let abs x = maxn x (neg x) (* TeX units *) (* we have to do this by hand because we cannot use the Picture module here *) let xlength p = mkNXPart (mkPTSub (mkPTPicCorner p `Northeast) (mkPTPicCorner p `Northwest)) let ylength p = mkNYPart (mkPTSub (mkPTPicCorner p `Northeast) (mkPTPicCorner p `Southeast)) let pic s = mkPicture (mkPITex s) let em_factor = xlength (pic "m") let ex_factor = ylength (pic "x") let em f = f *./ em_factor let ex f = f *./ ex_factor