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