Legend:
Page
Library
Module
Module type
Parameter
Class
Class type
Source
Source file archimedes_cairo.ml
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273(* File: archimedes_cairo.ml
Copyright (C) 2009
Bertrand Desmons <Bertrand.Desmons@umons.ac.be>
Christophe Troestler <Christophe.Troestler@umons.ac.be>
WWW: http://math.umh.ac.be/an/software/
This library is free software; you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License version 3 or
later as published by the Free Software Foundation, with the special
exception on linking described in the file LICENSE.
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 file
LICENSE for more details. *)(** Cairo Archimedes plugin *)moduleA=ArchimedesopenBigarraymoduleM=A.MatrixmoduleB:A.Backend.Capabilities=structincludeCairoletname="cairo"typet=Cairo.context(* Same type (same internal representation), just in different modules *)letset_line_captc=set_line_capt(matchcwith|A.Backend.BUTT->Cairo.BUTT|A.Backend.ROUND->Cairo.ROUND|A.Backend.SQUARE->Cairo.SQUARE)letget_line_capt=(matchget_line_captwith|Cairo.BUTT->A.Backend.BUTT|Cairo.ROUND->A.Backend.ROUND|Cairo.SQUARE->A.Backend.SQUARE)letset_line_jointj=set_line_joint(matchjwith|A.Backend.JOIN_MITER->Cairo.JOIN_MITER|A.Backend.JOIN_ROUND->Cairo.JOIN_ROUND|A.Backend.JOIN_BEVEL->Cairo.JOIN_BEVEL)letget_line_joint=(matchget_line_jointwith|Cairo.JOIN_MITER->A.Backend.JOIN_MITER|Cairo.JOIN_ROUND->A.Backend.JOIN_ROUND|Cairo.JOIN_BEVEL->A.Backend.JOIN_BEVEL)letpath_extentst=(* (Obj.magic(Cairo.Path.extents t): M.rectangle) *)lete=Cairo.Path.extentstin{M.x=e.Cairo.x;y=e.Cairo.y;w=e.Cairo.w;h=e.Cairo.h}letclose_patht=Cairo.Path.closetletclear_patht=Cairo.Path.cleartletset_dashtofsarr=set_dasht~ofsarrletset_matrixtm=(* let m' = (Obj.magic m : Cairo.matrix) in *)letm'={Cairo.xx=m.M.xx;xy=m.M.xy;yx=m.M.yx;yy=m.M.yy;x0=m.M.x0;y0=m.M.y0}inset_matrixtm'letget_matrixt=(* (Obj.magic (get_matrix cr) : Backend.matrix) *)letm=get_matrixtin{M.xx=m.Cairo.xx;xy=m.Cairo.xy;yx=m.Cairo.yx;yy=m.Cairo.yy;x0=m.Cairo.x0;y0=m.Cairo.y0}letflipy_=trueletset_colortc=letr,g,b,a=A.Color.get_rgba cinCairo.set_source_rgbatrgbaletarct~r~a1~a2=letx,y=Cairo.Path.get_current_pointtinletx=x-.r*.cosa1andy=y-.r*.sina1inarct~x~y~r~a1~a2(* identity CTM -- never modified *)letid={Cairo.xx=1.;xy=0.;yx=0.;yy=1.;x0=0.;y0=0.}letshowt=Cairo.Surface.flush(get_targett)letclip_rectanglet~x~y~w~h=Cairo.Path.cleart;Cairo.rectanglet~x~y~w~h;Cairo.clipt(* FIXME: better error message for options *)letmake~optionswidthheight=letsurface=matchoptionswith|["PDF";fname]->PDF.createfnamewidthheight|["PS";fname]->PS.createfnamewidthheight|["SVG";fname]->SVG.create~fname~width~height|["PNG";_]->(* saving done by the close function *)Image.createImage.ARGB32(truncatewidth)(truncateheight)|[]->(* interactive display. FIXME: when ready *)Image.createImage.ARGB32(truncatewidth)(truncateheight)|_->letopt=String.concat"; "optionsinfailwith("Archimedes_cairo.make: options ["^opt^"] not understood")inletcr=Cairo.createsurfacein(* Round line caps are the only option currently offered by
graphics. Be coherent with that. *)Cairo.set_line_capcrCairo.ROUND;crletclose~optionst=letsurface=Cairo.get_targettin(matchoptionswith|["PNG";fname]->PNG.writesurfacefname;|_->());Surface.finishsurfaceletstrokecr=(* FIXME: Do we really want this? are we not supposed to always
draw in a nice coordinate system? *)letm=Cairo.get_matrixcrinCairo.set_matrixcrid;(* to avoid the lines being deformed by [m] *)Cairo.strokecr;Cairo.set_matrixcrmletstroke_preservecr=letm=Cairo.get_matrixcrinCairo.set_matrixcrid;(* to avoid the lines being deformed by [m] *)Cairo.stroke_preservecr;Cairo.set_matrixcrmmoduleP=Archimedes_internals.Pathletpath_to_cairocr=function|P.Move_to(x,y)->Cairo.move_tocrxy|P.Line_to(x,y)->(* FIXME: Maybe it souldn't be to the backend to handle that. *)ifx=x&&y=ythenCairo.line_tocrxy|P.Curve_to(_,_,x1,y1,x2,y2,x3,y3)->Cairo.curve_tocrx1y1x2y2x3y3|P.Close(_,_)->Cairo.Path.closecr|P.Array(x,y,i0,i1)->ifi0<=i1thenfori=i0toi1doifx.(i)=x.(i)&&y.(i)=y.(i)thenCairo.line_tocrx.(i)y.(i)doneelsefori=i0downtoi1doifx.(i)=x.(i)&&y.(i)=y.(i)thenCairo.line_tocrx.(i)y.(i)done|P.Fortran(x,y,i0,i1)->ifi0<=i1thenfori=i0toi1doifx.{i}=x.{i}&&y.{i}=y.{i}thenCairo.line_tocrx.{i}y.{i}doneelsefori=i0downtoi1doifx.{i}=x.{i}&&y.{i}=y.{i}thenCairo.line_tocrx.{i}y.{i}done|P.C(x,y,i0,i1)->ifi0<=i1thenfori=i0toi1doifx.{i}=x.{i}&&y.{i}=y.{i}thenCairo.line_tocrx.{i}y.{i}doneelsefori=i0downtoi1doifx.{i}=x.{i}&&y.{i}=y.{i}thenCairo.line_tocrx.{i}y.{i}done(* The clipping is taken care of by the cairo backend. *)letstroke_path_preservecrp=Cairo.Path.clearcr;P.iterp(path_to_cairocr);(* Line width is in defaukt coordinates: *)letm=Cairo.get_matrixcrinCairo.set_matrixcrid;Cairo.strokecr;(* no need to preserve the copy of the path *)Cairo.set_matrixcrmletfill_path_preservecrp=Cairo.Path.clearcr;P.iterp(path_to_cairocr);Cairo.fillcrletfill_with_colorcrc=letsource=Cairo.get_sourcecrinset_colorcrc;letop=Cairo.get_operatorcrinCairo.set_operatorcrCairo.SOURCE;Cairo.fillcr;Cairo.set_operatorcrop;Cairo.set_sourcecrsourceletselect_font_facetslantweightfamily=(* Could be (unsafely) optimized *)letslant=matchslantwith|A.Backend.Upright->Cairo.Upright|A.Backend.Italic->Cairo.Italicandweight=matchweightwith|A.Backend.Normal->Cairo.Normal|A.Backend.Bold->Cairo.BoldinCairo.select_font_facet~slant~weightfamily(* TODO: add an option for alignment to baseline (using font_extents)
instead of text extents. *)letshow_textcr~rotate~x~ypostext=(* Compute the angle between the desired direction and the X axis
in the device coord. system. *)letdx,dy=user_to_device_distancecr(cosrotate)(sinrotate)inletangle=atan2dydxinCairo.savecr;Cairo.move_tocrxy;Cairo.set_matrixcrid;Cairo.rotatecrangle;lette=Cairo.text_extentscrtextinletx0=matchposwith|A.Backend.CC|A.Backend.CT|A.Backend.CB->te.x_bearing+.0.5*.te.width|A.Backend.RC|A.Backend.RT|A.Backend.RB->te.x_bearing|A.Backend.LC|A.Backend.LT|A.Backend.LB->te.x_bearing+.te.widthandy0=matchposwith|A.Backend.CC|A.Backend.RC|A.Backend.LC->te.y_bearing+.0.5*.te.height|A.Backend.CT|A.Backend.RT|A.Backend.LT->te.y_bearing+.te.height|A.Backend.CB|A.Backend.RB|A.Backend.LB->te.y_bearinginCairo.rel_move_tocr(-.x0)(-.y0);Cairo.show_textcrtext;Cairo.strokecr;(* without this, the current position is the end
of the text which is not desired. *)Cairo.restorecrlettext_extentsttext=Cairo.savet;Cairo.set_matrixtid;lette=Cairo.text_extentsttextinCairo.restoret;(*An extents is always expressed in current coordinates; however,
show_text switches to device coordinates before "making the
text". So we need to go to user coordinates.*)(*Note: The following transformations assume that the coordinates
are orthogonal.*)letx,y=Cairo.device_to_user_distancette.x_bearingte.y_bearinginletw,h=Cairo.device_to_user_distancette.widthte.heightin(* FIXME: y text extents in Cairo are given with the bearing from
origin to *topmost* part of the glyphs. However, in normalized
coordinates (e.g: for Viewport), we want them to be expressed from
the downmost part. *){M.x=x;y=-.y;w=w;h=h}endlet()=letmoduleU=A.Backend.Register(B)in()(* Local Variables: *)(* compile-command: "make -C .. -k" *)(* End: *)