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