1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
|
%%
%% %CopyrightBegin%
%%
%% Copyright Ericsson AB 1996-2016. All Rights Reserved.
%%
%% Licensed under the Apache License, Version 2.0 (the "License");
%% you may not use this file except in compliance with the License.
%% You may obtain a copy of the License at
%%
%% http://www.apache.org/licenses/LICENSE-2.0
%%
%% Unless required by applicable law or agreed to in writing, software
%% distributed under the License is distributed on an "AS IS" BASIS,
%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
%% See the License for the specific language governing permissions 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".
|
