diff options
Diffstat (limited to 'lib/gs/src/gstk_font.erl')
| -rw-r--r-- | lib/gs/src/gstk_font.erl | 254 |
1 files changed, 254 insertions, 0 deletions
diff --git a/lib/gs/src/gstk_font.erl b/lib/gs/src/gstk_font.erl new file mode 100644 index 0000000000..ac91e8a92a --- /dev/null +++ b/lib/gs/src/gstk_font.erl @@ -0,0 +1,254 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1996-2009. All Rights Reserved. +%% +%% The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved online at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% %CopyrightEnd% +%% + +%% +%%% Purpose : The font model + +%% ########################################################################### +%% +%% This module handle fonts. It was changed for Tcl 8.2 but it could +%% probably be simplified more. +%% +%% In Tcl 8.2 we can use named fonts. So the whe get a font request we +%% first check if it already exists and if not we name it and insert it +%% into the database. +%% +%% The font naming is also changedin Tcl 8.2. +%% +%% In Tcl 8.2 there is a way to find out the width of a string in +%% a specified font. +%% +%% ########################################################################### + +-module(gstk_font). + +%-compile(export_all). + +-export([init/0,choose_ascii/2,choose/2,width_height/3]). + + +-ifndef(NEW_WIDTH_HEIGHT). +init() -> + %% hack. the only way to find the size of a text seems to be to put + %% it into a label in an unmappen window (DummyFontWindow) + gstk:exec("toplevel .dfw;wm withdraw .dfw;" %deiconify + "label .dfw.l -text dummyinittxt -padx 0 -pady 0 -borderwidth 0;" + "pack .dfw.l"). +-else. +init() -> true. +-endif. + +%%---------------------------------------------------------------------- +%% Returns: undefined if font doesn't exist +%% {WidthPixels, HeightPixels} +%%---------------------------------------------------------------------- +-ifndef(NEW_WIDTH_HEIGHT). +width_height(_DB, FontSpec, Txt) -> + FontSpecStr = tk_font_spec(norm_font_spec(FontSpec)), + case gstk:call([".dfw.l co -font {", FontSpecStr,"}", + " -text ", gstk:to_ascii(Txt)]) of + {result, _} -> + Width = tcl2erl:ret_int("update idletasks;winfo w .dfw.l"), + Height = tcl2erl:ret_int("winfo h .dfw.l"), +% io:format("width_height(~p,~p) =>\n~p\n\n",[FontSpec,Txt,{Width,Height}]), + {Width,Height}; + _Bad_Result -> +% io:format("width_height(~p,~p) =>\nundefined\n\n",[FontSpec,Txt]), + undefined + end. +-else. +%% This code should work but does't. Tk gives incorrect +%% values if asking to fast or something /kent +width_height(DB, FontSpec, Txt) when tuple(FontSpec) -> + NormFontSpec = norm_font_spec(FontSpec), + FontSpecStr = tk_font_spec(NormFontSpec), + {Family,_,Size} = NormFontSpec, + LineHeight = + case cached_line_height(DB, {Family,Size}) of + undefined -> + LineH = tcl2erl:ret_int( + ["font metrics {",FontSpecStr,"} -linespace"]), + cache_line_height(DB, {Family,Size}, LineH), + LineH; + LineH -> + LineH + end, + EscapedText = gstk:to_ascii(Txt), + Width = tcl2erl:ret_int( + ["font measure {",FontSpecStr,"} ",EscapedText]), + Height = LineHeight * line_count(Txt), + {Width,Height}; + +width_height(_DB, FontSpec, Txt) when list(FontSpec) -> + EscapedText = gstk:to_ascii(Txt), + Width = + tcl2erl:ret_int(["font measure {",FontSpec,"} ",EscapedText]), + LineHeight = + tcl2erl:ret_int(["font metrics {",FontSpec,"} -linespace"]), + Height = LineHeight * line_count(Txt), + {Width,Height}. + +cached_line_height(DB,FontSpec) -> + gstk_db:lookup(DB, {cached_line_height,FontSpec}). + +cache_line_height(DB,FontSpec,Size) -> + gstk_db:insert(DB, {cached_line_height,FontSpec}, Size). + +line_count(Line) -> + line_count(Line, 1). + +line_count([H | T], Count) -> + Count + line_count(H, 0) + line_count(T, 0); +line_count($\n, Count) -> Count + 1; +line_count(Char, Count) when integer(Char) -> Count; +line_count([], Count) -> Count. +-endif. + +% "expr [font metrics ",FSpec," -linespace] * \ +% [regsub -all \\n ",Txt," {} ignore]" + +%%---------------------------------------------------------------------- +%% Returns: Font specification string in Tk format +%% +%% The input is {Family,Size} or {Family,Style,Size} where Family and +%% Style are atoms ?! FIXME true??? +%%---------------------------------------------------------------------- +choose_ascii(DB, Font) -> + {Fam,Styl,Siz} = choose(DB, Font), + {variable,V} =gstk_db:lookup(DB,{font,Fam,Styl,Siz}), +% io:format("choose_ascii(~p) =>\n~p\n\n",[Font,V]), + V. + +%% DB contains: {font,Fam,Style,Size} -> {replaced_by,{font,Fam,Style,Size}} or +%% {variable, TkVariableStrInclDollar} + +%% ########################################################################### +%% +%% We create a new font name on the other side and store the name in the +%% database. We reorder the options so that they have a predefined order. +%% +%% ########################################################################### + +choose(DB, FontSpec) -> + choose_font(DB, norm_font_spec(FontSpec)). + +choose_font(DB, {Fam,Styl,Siz}) -> + Fam0 = map_family(Fam), + case gstk_db:lookup(DB,{font,Fam0,Styl,Siz}) of + {variable,_OwnFontName} -> true; + undefined -> + N = gstk_db:counter(DB,font), % FIXME: Can use "font create" + % without name to get unique name + NewName=["f",gstk:to_ascii(N)], +% io:format("~s\n\n", +% [lists:flatten(["font create ",NewName," ", +% tk_font_spec({Fam0,Styl,Siz})])]), + gstk:exec(["font create ",NewName," ", + tk_font_spec({Fam0,Styl,Siz})]), + %% should us variable syntax gs(f1) instead + %% have to recompile erlcall to define this global gs var + V2 = {variable,NewName}, + gstk_db:insert(DB,{font,Fam0,Styl,Siz},V2), + true + end, +% io:format("choose(~p,~p,~p) =>\n~p\n\n",[Fam,Styl,Siz,{Fam0,Styl,Siz}]), + {Fam0,Styl,Siz}. + + +%% ----- The Font Model ----- + +%% Guaranteed system fonts to exists in Tk 8.2 are: +%% +%% Windows : system systemfixed ansi ansifixed device oemfixed +%% Unix : fixed +%% +%% Times, Courier and Helvetica always exists. Tk try to substitute +%% others with the best matchin font. + +%% We map GS font style and names to something we know Tk 8 have. +%% We know Tk have 'times', 'courier', 'helvetica' and 'fixed'. +%% +%% GS style specification is 'bold' or 'italic'. +%% GS family is a typeface of type 'times', 'courier', 'helvetica', +%% 'symbol', 'new_century_schoolbook', or 'screen' (which is a suitable +%% screen font). +%% +%% Note that 'symbol' may not be present and this is not handled. +%% +%% The X/Tk8 font handling don't work very well. The fonts are +%% scaled "tk scaling", we can display a 9 and 10 point helvetica +%% but "font actual {helvetica 9}" will return 10 points.... + +map_family(new_century_schoolbook) -> + times; +map_family(Fam) -> + Fam. + +% Normalize so can make the coding easier and compare font +% specifications stored in database with new ones. We ignore invalid +% entries in the list. + +norm_font_spec({Family,Size}) -> + {Family,[],Size}; +norm_font_spec({Family,Style,Size}) -> + {Family,norm_style(Style),Size}. + +norm_style(bold) -> + [bold]; +norm_style(italic) -> + [italic]; +norm_style([italic]) -> + [italic]; +norm_style([bold]) -> + [bold]; +norm_style([bold,italic] = Style) -> + Style; +norm_style([italic,bold]) -> + [bold,italic]; +norm_style(List) when is_list(List) -> % not well formed list, ignore garbage + case {lists:member(bold, List),lists:member(italic, List)} of + {true,true} -> + [bold,italic]; + {true,_} -> + [bold]; + {_,true} -> + [italic]; + _ -> + [] % ignore garbage + end; +norm_style(_Any) -> % ignore garbage + []. + + +% Create a tcl string from a normalized font specification +% The style list is normalized. + +tk_font_spec({Fam,Style,Size}) -> + ["-family ",gstk:to_ascii(Fam), + " -size ",gstk:to_ascii(-Size), + tk_font_spec_style(Style)]. + +tk_font_spec_style([]) -> + ""; +tk_font_spec_style([bold]) -> + " -weight bold"; +tk_font_spec_style([italic]) -> + " -slant italic"; +tk_font_spec_style([bold,italic]) -> + " -weight bold -slant italic". |