1# ----------------------------------------------------------------------------
2#  font.tcl
3#  This file is part of Unifix BWidget Toolkit
4# ----------------------------------------------------------------------------
5#  Index of commands:
6#     - SelectFont::create
7#     - SelectFont::configure
8#     - SelectFont::cget
9#     - SelectFont::_draw
10#     - SelectFont::_destroy
11#     - SelectFont::_modstyle
12#     - SelectFont::_update
13#     - SelectFont::_getfont
14#     - SelectFont::_init
15# ----------------------------------------------------------------------------
16
17namespace eval SelectFont {
18    Widget::define SelectFont font Dialog LabelFrame ScrolledWindow
19
20    Widget::declare SelectFont {
21        {-title		String		"Font selection" 0}
22        {-parent	String		"" 0}
23        {-background	TkResource	"" 0 frame}
24
25        {-type		Enum		dialog        0 {dialog toolbar}}
26        {-font		TkResource	""            0 label}
27	{-families	String		"all"         1}
28	{-querysystem	Boolean		1             0}
29	{-styles	String		"bold italic underline overstrike" 1}
30        {-command	String		""            0}
31        {-sampletext	String		"Sample Text" 0}
32        {-bg		Synonym		-background}
33    }
34
35    variable _families
36    variable _styleOff
37    array set _styleOff [list bold normal italic roman]
38    variable _sizes     {4 5 6 7 8 9 10 11 12 13 14 15 16 \
39	    17 18 19 20 21 22 23 24}
40
41    # Set up preset lists of fonts, so the user can avoid the painfully slow
42    # loadfont process if desired.
43    if { [string equal $::tcl_platform(platform) "windows"] } {
44	set presetVariable [list	\
45		7x14			\
46		Arial			\
47		{Arial Narrow}		\
48		{Lucida Sans}		\
49		{MS Sans Serif}		\
50		{MS Serif}		\
51		{Times New Roman}	\
52		]
53	set presetFixed    [list	\
54		6x13			\
55		{Courier New}		\
56		FixedSys		\
57		Terminal		\
58		]
59	set presetAll      [list	\
60		6x13			\
61		7x14			\
62		Arial			\
63		{Arial Narrow}		\
64		{Courier New}		\
65		FixedSys		\
66		{Lucida Sans}		\
67		{MS Sans Serif}		\
68		{MS Serif}		\
69		Terminal		\
70		{Times New Roman}	\
71		]
72    } else {
73	set presetVariable [list	\
74		helvetica		\
75		lucida			\
76		lucidabright		\
77		{times new roman}	\
78		]
79	set presetFixed    [list	\
80		courier			\
81		fixed			\
82		{lucida typewriter}	\
83		screen			\
84		serif			\
85		terminal		\
86		]
87	set presetAll      [list	\
88		courier			\
89		fixed			\
90		helvetica		\
91		lucida			\
92		lucidabright		\
93		{lucida typewriter}	\
94		screen			\
95		serif			\
96		terminal		\
97		{times new roman}	\
98		]
99    }
100    array set _families [list \
101	    presetvariable	$presetVariable	\
102	    presetfixed		$presetFixed	\
103	    presetall		$presetAll	\
104	    ]
105
106    variable _widget
107}
108
109
110# ----------------------------------------------------------------------------
111#  Command SelectFont::create
112# ----------------------------------------------------------------------------
113proc SelectFont::create { path args } {
114    variable _families
115    variable _sizes
116    variable $path
117    upvar 0  $path data
118
119    # Initialize the internal rep of the widget options
120    Widget::init SelectFont "$path#SelectFont" $args
121
122    if { [Widget::getoption "$path#SelectFont" -querysystem] } {
123        loadfont [Widget::getoption "$path#SelectFont" -families]
124    }
125
126    set bg [Widget::getoption "$path#SelectFont" -background]
127    set _styles [Widget::getoption "$path#SelectFont" -styles]
128    if { [Widget::getoption "$path#SelectFont" -type] == "dialog" } {
129        Dialog::create $path -modal local -default 0 -cancel 1 -background $bg \
130            -title  [Widget::getoption "$path#SelectFont" -title] \
131            -parent [Widget::getoption "$path#SelectFont" -parent]
132
133        set frame [Dialog::getframe $path]
134        set topf  [frame $frame.topf -relief flat -borderwidth 0 -background $bg]
135
136        set labf1 [LabelFrame::create $topf.labf1 -text "Font" -name font \
137                       -side top -anchor w -relief flat -background $bg]
138        set sw    [ScrolledWindow::create [LabelFrame::getframe $labf1].sw \
139                       -background $bg]
140        set lbf   [listbox $sw.lb \
141                       -height 5 -width 25 -exportselection false -selectmode browse]
142        ScrolledWindow::setwidget $sw $lbf
143        LabelFrame::configure $labf1 -focus $lbf
144	if { [Widget::getoption "$path#SelectFont" -querysystem] } {
145	    set fam [Widget::getoption "$path#SelectFont" -families]
146	} else {
147	    set fam "preset"
148	    append fam [Widget::getoption "$path#SelectFont" -families]
149	}
150        eval [list $lbf insert end] $_families($fam)
151        set script "set [list SelectFont::${path}(family)] \[%W curselection\];\
152		        SelectFont::_update [list $path]"
153        bind $lbf <ButtonRelease-1> $script
154        bind $lbf <space>           $script
155	bind $lbf <1>               [list focus %W]
156        pack $sw -fill both -expand yes
157
158        set labf2 [LabelFrame::create $topf.labf2 -text "Size" -name size \
159                       -side top -anchor w -relief flat -background $bg]
160        set sw    [ScrolledWindow::create [LabelFrame::getframe $labf2].sw \
161                       -scrollbar vertical -background $bg]
162        set lbs   [listbox $sw.lb \
163                       -height 5 -width 6 -exportselection false -selectmode browse]
164        ScrolledWindow::setwidget $sw $lbs
165        LabelFrame::configure $labf2 -focus $lbs
166        eval [list $lbs insert end] $_sizes
167        set script "set [list SelectFont::${path}(size)] \[%W curselection\];\
168			SelectFont::_update [list $path]"
169        bind $lbs <ButtonRelease-1> $script
170        bind $lbs <space>           $script
171	bind $lbs <1>               [list focus %W]
172        pack $sw -fill both -expand yes
173
174        set labf3 [LabelFrame::create $topf.labf3 -text "Style" -name style \
175                       -side top -anchor w -relief sunken -bd 1 -background $bg]
176        set subf  [LabelFrame::getframe $labf3]
177        foreach st $_styles {
178            set name [lindex [BWidget::getname $st] 0]
179            if { $name == "" } {
180                set name [string toupper $name 0]
181            }
182            checkbutton $subf.$st -text $name \
183                -variable   SelectFont::$path\($st\) \
184                -background $bg \
185                -command    [list SelectFont::_update $path]
186            bind $subf.$st <Return> break
187            pack $subf.$st -anchor w
188        }
189        LabelFrame::configure $labf3 -focus $subf.[lindex $_styles 0]
190
191        pack $labf1 -side left -anchor n -fill both -expand yes
192        pack $labf2 -side left -anchor n -fill both -expand yes -padx 8
193        pack $labf3 -side left -anchor n -fill both -expand yes
194
195        set botf [frame $frame.botf -width 100 -height 50 \
196                      -bg white -bd 0 -relief flat \
197                      -highlightthickness 1 -takefocus 0 \
198                      -highlightbackground black \
199                      -highlightcolor black]
200
201        set lab  [label $botf.label \
202                      -background white -foreground black \
203                      -borderwidth 0 -takefocus 0 -highlightthickness 0 \
204                      -text [Widget::getoption "$path#SelectFont" -sampletext]]
205        place $lab -relx 0.5 -rely 0.5 -anchor c
206
207        pack $topf -pady 4 -fill both -expand yes
208        pack $botf -pady 4 -fill x
209
210        Dialog::add $path -name ok
211        Dialog::add $path -name cancel
212
213        set data(label) $lab
214        set data(lbf)   $lbf
215        set data(lbs)   $lbs
216
217        _getfont $path
218
219	Widget::create SelectFont $path 0
220
221        return [_draw $path]
222    } else {
223	if { [Widget::getoption "$path#SelectFont" -querysystem] } {
224	    set fams [Widget::getoption "$path#SelectFont" -families]
225	} else {
226	    set fams "preset"
227	    append fams [Widget::getoption "$path#SelectFont" -families]
228	}
229        frame $path -relief flat -borderwidth 0 -background $bg
230        bind $path <Destroy> [list SelectFont::_destroy $path]
231        set lbf [ComboBox::create $path.font \
232                     -highlightthickness 0 -takefocus 0 -background $bg \
233                     -values   $_families($fams) \
234                     -textvariable SelectFont::$path\(family\) \
235                     -editable 0 \
236                     -modifycmd [list SelectFont::_update $path]]
237        set lbs [ComboBox::create $path.size \
238                     -highlightthickness 0 -takefocus 0 -background $bg \
239                     -width    4 \
240                     -values   $_sizes \
241                     -textvariable SelectFont::$path\(size\) \
242                     -editable 0 \
243                     -modifycmd [list SelectFont::_update $path]]
244        pack $lbf -side left -anchor w
245        pack $lbs -side left -anchor w -padx 4
246        foreach st $_styles {
247            button $path.$st \
248                -highlightthickness 0 -takefocus 0 -padx 0 -pady 0 -bd 2 \
249                -background $bg \
250                -image  [Bitmap::get $st] \
251                -command [list SelectFont::_modstyle $path $st]
252            pack $path.$st -side left -anchor w
253        }
254        set data(label) ""
255        set data(lbf)   $lbf
256        set data(lbs)   $lbs
257        _getfont $path
258
259	return [Widget::create SelectFont $path]
260    }
261
262    return $path
263}
264
265
266# ----------------------------------------------------------------------------
267#  Command SelectFont::configure
268# ----------------------------------------------------------------------------
269proc SelectFont::configure { path args } {
270    set _styles [Widget::getoption "$path#SelectFont" -styles]
271
272    set res [Widget::configure "$path#SelectFont" $args]
273
274    if { [Widget::hasChanged "$path#SelectFont" -font font] } {
275        _getfont $path
276    }
277    if { [Widget::hasChanged "$path#SelectFont" -background bg] } {
278        switch -- [Widget::getoption "$path#SelectFont" -type] {
279            dialog {
280                Dialog::configure $path -background $bg
281                set topf [Dialog::getframe $path].topf
282                $topf configure -background $bg
283                foreach labf {labf1 labf2} {
284                    LabelFrame::configure $topf.$labf -background $bg
285                    set subf [LabelFrame::getframe $topf.$labf]
286                    ScrolledWindow::configure $subf.sw -background $bg
287                    $subf.sw.lb configure -background $bg
288                }
289                LabelFrame::configure $topf.labf3 -background $bg
290                set subf [LabelFrame::getframe $topf.labf3]
291                foreach w [winfo children $subf] {
292                    $w configure -background $bg
293                }
294            }
295            toolbar {
296                $path configure -background $bg
297                ComboBox::configure $path.font -background $bg
298                ComboBox::configure $path.size -background $bg
299                foreach st $_styles {
300                    $path.$st configure -background $bg
301                }
302            }
303        }
304    }
305    return $res
306}
307
308
309# ----------------------------------------------------------------------------
310#  Command SelectFont::cget
311# ----------------------------------------------------------------------------
312proc SelectFont::cget { path option } {
313    return [Widget::cget "$path#SelectFont" $option]
314}
315
316
317# ----------------------------------------------------------------------------
318#  Command SelectFont::loadfont
319# ----------------------------------------------------------------------------
320proc SelectFont::loadfont {{which all}} {
321    variable _families
322
323    # initialize families
324    if {![info exists _families(all)]} {
325	set _families(all) [lsort -dictionary [font families]]
326    }
327    if {[regexp {fixed|variable} $which] \
328	    && ![info exists _families($which)]} {
329	# initialize families
330	set _families(fixed) {}
331	set _families(variable) {}
332	foreach family $_families(all) {
333	    if { [font metrics [list $family] -fixed] } {
334		lappend _families(fixed) $family
335	    } else {
336		lappend _families(variable) $family
337	    }
338	}
339    }
340    return
341}
342
343
344# ----------------------------------------------------------------------------
345#  Command SelectFont::_draw
346# ----------------------------------------------------------------------------
347proc SelectFont::_draw { path } {
348    variable $path
349    upvar 0  $path data
350
351    $data(lbf) selection clear 0 end
352    $data(lbf) selection set $data(family)
353    $data(lbf) activate $data(family)
354    $data(lbf) see $data(family)
355    $data(lbs) selection clear 0 end
356    $data(lbs) selection set $data(size)
357    $data(lbs) activate $data(size)
358    $data(lbs) see $data(size)
359    _update $path
360
361    if { [Dialog::draw $path] == 0 } {
362        set result [Widget::getoption "$path#SelectFont" -font]
363    } else {
364        set result ""
365    }
366    unset data
367    Widget::destroy "$path#SelectFont"
368    destroy $path
369    return $result
370}
371
372
373# ----------------------------------------------------------------------------
374#  Command SelectFont::_modstyle
375# ----------------------------------------------------------------------------
376proc SelectFont::_modstyle { path style } {
377    variable $path
378    upvar 0  $path data
379
380    if { $data($style) == 1 } {
381        $path.$style configure -relief raised
382        set data($style) 0
383    } else {
384        $path.$style configure -relief sunken
385        set data($style) 1
386    }
387    _update $path
388}
389
390
391# ----------------------------------------------------------------------------
392#  Command SelectFont::_update
393# ----------------------------------------------------------------------------
394proc SelectFont::_update { path } {
395    variable _families
396    variable _sizes
397    variable _styleOff
398    variable $path
399    upvar 0  $path data
400
401    set type [Widget::getoption "$path#SelectFont" -type]
402    set _styles [Widget::getoption "$path#SelectFont" -styles]
403    if { [Widget::getoption "$path#SelectFont" -querysystem] } {
404	set fams [Widget::getoption "$path#SelectFont" -families]
405    } else {
406	set fams "preset"
407	append fams [Widget::getoption "$path#SelectFont" -families]
408    }
409    if { $type == "dialog" } {
410        set curs [$path:cmd cget -cursor]
411        $path:cmd configure -cursor watch
412    }
413    if { [Widget::getoption "$path#SelectFont" -type] == "dialog" } {
414        set font [list [lindex $_families($fams) $data(family)] \
415		[lindex $_sizes $data(size)]]
416    } else {
417        set font [list $data(family) $data(size)]
418    }
419    foreach st $_styles {
420        if { $data($st) } {
421            lappend font $st
422        } elseif {[info exists _styleOff($st)]} {
423	    # This adds the default bold/italic value to a font
424	    #lappend font $_styleOff($st)
425	}
426    }
427    Widget::setoption "$path#SelectFont" -font $font
428    if { $type == "dialog" } {
429        $data(label) configure -font $font
430        $path:cmd configure -cursor $curs
431    } elseif { [set cmd [Widget::getoption "$path#SelectFont" -command]] != "" } {
432        uplevel \#0 $cmd
433    }
434}
435
436
437# ----------------------------------------------------------------------------
438#  Command SelectFont::_getfont
439# ----------------------------------------------------------------------------
440proc SelectFont::_getfont { path } {
441    variable _families
442    variable _sizes
443    variable $path
444    upvar 0  $path data
445
446    array set font [font actual [Widget::getoption "$path#SelectFont" -font]]
447    set data(bold)       [expr {![string equal $font(-weight) "normal"]}]
448    set data(italic)     [expr {![string equal $font(-slant)  "roman"]}]
449    set data(underline)  $font(-underline)
450    set data(overstrike) $font(-overstrike)
451    set _styles [Widget::getoption "$path#SelectFont" -styles]
452    if { [Widget::getoption "$path#SelectFont" -querysystem] } {
453	set fams [Widget::getoption "$path#SelectFont" -families]
454    } else {
455	set fams "preset"
456	append fams [Widget::getoption "$path#SelectFont" -families]
457    }
458    if { [Widget::getoption "$path#SelectFont" -type] == "dialog" } {
459        set idxf [lsearch $_families($fams) $font(-family)]
460        set idxs [lsearch $_sizes    $font(-size)]
461        set data(family) [expr {$idxf >= 0 ? $idxf : 0}]
462        set data(size)   [expr {$idxs >= 0 ? $idxs : 0}]
463    } else {
464        set data(family) $font(-family)
465        set data(size)   $font(-size)
466        foreach st $_styles {
467            $path.$st configure -relief [expr {$data($st) ? "sunken":"raised"}]
468        }
469    }
470}
471
472
473# ----------------------------------------------------------------------------
474#  Command SelectFont::_destroy
475# ----------------------------------------------------------------------------
476proc SelectFont::_destroy { path } {
477    variable $path
478    upvar 0  $path data
479    unset data
480    Widget::destroy "$path#SelectFont"
481}
482