The R13B03 release.OTP_R13B03

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".