00001 ######################################################################
00002 # Name: fontchooser.tcl
00003 # Author: Trevor Williams (trevorw@sgi.com)
00004 # Date: 01/07/2016
00005 # Brief: Provides a UI and associated functionality for choosing a
00006 # font.
00007 # Attributions:
00008 # This code mainly comes from the ChooseFont package created
00009 # by Keith Vetter (June 2006).
00010 ######################################################################
00011
00012 namespace eval fontchooser {
00013
00014 variable default_font
00015
00016 array set data {}
00017
00018 # Set the current default font
00019 set default_font [[ttk::entry .___e] cget -font]
00020 destroy .___e
00021
00022 ######################################################################
00023 # Creates and configures a fontchooser widget and returns the pathname.
00024 proc create {w args} {
00025
00026 variable data
00027
00028 array set opts {
00029 -default ""
00030 -mono ""
00031 -effects 0
00032 -sizes ""
00033 -styles ""
00034 -highlight ""
00035 }
00036 array set opts $args
00037
00038 # Initialize variables
00039 switch $opts(-mono) {
00040 0 { set data($w,fonts) [lsort [find_font_class variable]] }
00041 1 { set data($w,fonts) [lsort [find_font_class mono]] }
00042 default { set data($w,fonts) [lsort [font families]] }
00043 }
00044 set data($w,styles) [expr {($opts(-styles) eq "") ? {Regular Italic Bold "Bold Italic"} : $opts(-styles)}]
00045 set data($w,sizes) [expr {($opts(-sizes) eq "") ? {6 7 8 9 10 11 12 14 16 18 20 22 24 26 28} : $opts(-sizes)}]
00046
00047 set data($w,font) ""
00048 set data($w,style) ""
00049 set data($w,size) ""
00050 set data($w,strike) 0
00051 set data($w,under) 0
00052
00053 set data($w,fonts,lcase) [string tolower $data($w,fonts)]
00054 set data($w,styles,lcase) [string tolower $data($w,styles)]
00055 set data($w,sizes,lcase) $data($w,sizes)
00056
00057 ttk::frame $w
00058 ttk::label $w.font -text "Font:"
00059 ttk::label $w.style -text "Font style:"
00060 ttk::label $w.size -text "Size:"
00061 ttk::entry $w.efont -textvariable fontchooser::data($w,font)
00062 ttk::entry $w.estyle -textvariable fontchooser::data($w,style)
00063 ttk::entry $w.esize -textvariable fontchooser::data($w,size) -width 0 \
00064 -validate key -validatecommand {string is double %P}
00065
00066 listbox $w.lfonts -listvariable fontchooser::data($w,fonts) -height 7 \
00067 -borderwidth 0 -highlightthickness 0 -relief flat \
00068 -yscrollcommand [list $w.sbfonts set] -height 7 -exportselection 0
00069 scroller::scroller $w.sbfonts -command [list $w.lfonts yview]
00070 listbox $w.lstyles -listvariable fontchooser::data($w,styles) -height 7 -exportselection 0 -relief flat
00071 listbox $w.lsizes -listvariable fontchooser::data($w,sizes) \
00072 -borderwidth 0 -highlightthickness 0 -relief flat \
00073 -yscroll [list $w.sbsizes set] -width 6 -height 7 -exportselection 0
00074 scroller::scroller $w.sbsizes -command [list $w.lsizes yview]
00075
00076 bind $w.lfonts <<ListboxSelect>> [list fontchooser::click $w font]
00077 bind $w.lstyles <<ListboxSelect>> [list fontchooser::click $w style]
00078 bind $w.lsizes <<ListboxSelect>> [list fontchooser::click $w size]
00079
00080 grid columnconfigure $w {0 3 6 9} -minsize 10
00081 grid columnconfigure $w {1 4 7} -weight 1
00082 grid x $w.font - x $w.style - x $w.size - x -sticky w
00083 grid x $w.efont - x $w.estyle - x $w.esize - x -sticky ew
00084 grid x $w.lfonts $w.sbfonts x $w.lstyles - x $w.lsizes $w.sbsizes x -sticky news
00085
00086 if {$opts(-effects)} {
00087
00088 ttk::labelframe $w.effects -text "Effects"
00089 ttk::checkbutton $w.effects.strike -variable fontchooser::data($w,strike) \
00090 -text " Strikeout" -command [list fontchooser::show $w]
00091 ttk::checkbutton $w.effects.under -variable fontchooser::data($w,under) \
00092 -text " Underline" -command [list fontchooser::show $w]
00093
00094 grid columnconfigure $w.effects 1 -weight 1
00095 grid $w.effects.strike -sticky w -padx 10
00096 grid $w.effects.under -sticky w -padx 10
00097
00098 grid $w.effects - x -sticky news -row 100 -column 1
00099
00100 }
00101
00102 ttk::labelframe $w.sample -text "Sample"
00103 ttk::label $w.sample.fsample -relief sunken
00104 set data($w,sample) [ttk::label $w.sample.fsample.sample -text "AaBbYyZz"]
00105 pack $w.sample.fsample -fill both -expand 1 -padx 10 -pady 10 -ipady 15
00106 pack $w.sample.fsample.sample -fill both -expand 1
00107 pack propagate $w.sample.fsample 0
00108
00109 grid rowconfigure $w 2 -weight 1
00110 grid rowconfigure $w 99 -minsize 30
00111 grid $w.sample - - - - -sticky news -row 100 -column 4
00112 grid rowconfigure $w 101 -minsize 30
00113
00114 trace variable fontchooser::data($w,size) w fontchooser::tracer
00115 trace variable fontchooser::data($w,style) w fontchooser::tracer
00116 trace variable fontchooser::data($w,font) w fontchooser::tracer
00117
00118 configure $w $opts(-default)
00119
00120 if {$opts(-mono) eq ""} {
00121 highlight $w $opts(-highlight)
00122 }
00123
00124 bind $w <Destroy> [list fontchooser::destroy $w]
00125
00126 return $w
00127
00128 }
00129
00130 ######################################################################
00131 # Configures the font chooser widget.
00132 proc configure {w {defaultFont ""}} {
00133
00134 variable data
00135
00136 # Figure out the default font if one was not specified
00137 if {$defaultFont eq ""} {
00138 set defaultFont [[ttk::entry .___e] cget -font]
00139 ::destroy .___e
00140 }
00141
00142 array set F [font actual $defaultFont]
00143
00144 set data($w,font) $F(-family)
00145 set data($w,size) $F(-size)
00146 set data($w,strike) $F(-overstrike)
00147 set data($w,under) $F(-underline)
00148 set data($w,style) "Regular"
00149 if {($F(-weight) eq "bold") && ($F(-slant) eq "italic")} {
00150 set data($w,style) "Bold Italic"
00151 } elseif {$F(-weight) eq "bold"} {
00152 set data($w,style) "Bold"
00153 } elseif {$F(-slant) eq "italic"} {
00154 set data($w,style) "Italic"
00155 }
00156
00157 # Update the UI
00158 foreach var [list font style size] {
00159 tracer data $w,$var w
00160 }
00161
00162 # Display the result
00163 show $w
00164
00165 }
00166
00167 ######################################################################
00168 # Highlights the fonts in the font list that are of a specific type.
00169 proc highlight {w highlight} {
00170
00171 variable data
00172
00173 if {$highlight ne ""} {
00174
00175 set hfonts [find_font_class $highlight]
00176 set i 0
00177
00178 foreach f $data($w,fonts) {
00179 if {[lsearch $hfonts $f] != -1} {
00180 $w.lfonts itemconfigure $i -foreground blue
00181 }
00182 incr i
00183 }
00184
00185 }
00186
00187 }
00188
00189 ######################################################################
00190 # Called when the widget is destroyed.
00191 proc destroy {w} {
00192
00193 variable data
00194
00195 array unset data $w,*
00196
00197 trace remove variable fontchooser::data($w,size) write fontchooser::tracer
00198 trace remove variable fontchooser::data($w,style) write fontchooser::tracer
00199 trace remove variable fontchooser::data($w,font) write fontchooser::tracer
00200
00201 }
00202
00203 ######################################################################
00204 # Called when one of the listboxes are clicked.
00205 proc click {w who} {
00206
00207 variable data
00208
00209 # Update the setting
00210 set data($w,$who) [$w.l${who}s get [$w.l${who}s curselection]]
00211
00212 }
00213
00214 ######################################################################
00215 # Called when one of the font variables are written to. Updates the UI.
00216 proc tracer {var1 var2 op} {
00217
00218 variable data
00219
00220 lassign [split $var2 ,] w var
00221
00222 # Clear the selection
00223 $w.l${var}s selection clear 0 end
00224
00225 # Find the exact (or closest) font match and get its index
00226 set value [string tolower $data($w,$var)]
00227 if {[set n [lsearch -exact $data($w,${var}s,lcase) $value]] == -1} {
00228 if {[set n [lsearch -glob $data($w,${var}s,lcase) "$value*"]] == -1} {
00229 return
00230 }
00231 }
00232
00233 # Set the value
00234 set data($w,$var) [lindex $data($w,${var}s) $n]
00235
00236 # Update the UI
00237 $w.e$var icursor end
00238 $w.e$var selection clear
00239 $w.l${var}s selection set $n
00240 $w.l${var}s see $n
00241
00242 # Display the font
00243 show $w
00244
00245 }
00246
00247 ######################################################################
00248 # Displays a sample of the selection options and generates the
00249 # <<FontChanged>> virtual event.
00250 proc show {w} {
00251
00252 variable data
00253
00254 set result [list -family $data($w,font) -size $data($w,size)]
00255
00256 switch $data($w,style) {
00257 "Bold" { lappend result -weight bold }
00258 "Italic" { lappend result -slant italic }
00259 "Bold Italic" { lappend result -weight bold -slant italic }
00260 }
00261
00262 if {$data($w,strike)} { lappend result -overstrike 1 }
00263 if {$data($w,under)} { lappend result -underline 1 }
00264
00265 # Display the sampled result and generate the FontChanged event
00266 if {![catch { $data($w,sample) config -font $result }]} {
00267 event generate $w <<FontChanged>> -data $result
00268 }
00269
00270 }
00271
00272 ######################################################################
00273 # Returns the font families that match the given type.
00274 proc find_font_class {{type mono}} {
00275
00276 set fm [list]
00277 set fv [list]
00278 foreach f [font families] {
00279 if {[font measure "{$f} 8" "A"] == [font measure "{$f} 8" "."]} {
00280 lappend fm $f
00281 } else {
00282 lappend fv $f
00283 }
00284 }
00285
00286 return [expr {($type eq "mono") ? $fm : $fv}]
00287
00288 }
00289
00290 }
00291
00292 ######################################################################
00293 # Creates a font chooser window.
00294 proc fontchooser {args} {
00295
00296 array set opts [list \
00297 -parent . \
00298 -initialfont $fontchooser::default_font \
00299 -title "" \
00300 -mono "" \
00301 -styles "" \
00302 -effects 1 \
00303 ]
00304 array set opts $args
00305
00306 set ::fontchooser_value ""
00307
00308 toplevel .fontwin
00309 wm title .fontwin $opts(-title)
00310 wm transient .fontwin $opts(-parent)
00311 wm resizable .fontwin 0 0
00312
00313 fontchooser::create .fontwin.fc -effects $opts(-effects) -default $opts(-initialfont) -highlight mono -mono $opts(-mono) -styles $opts(-styles)
00314
00315 bind .fontwin.fc <<FontChanged>> {
00316 set ::fontchooser_value %d
00317 .fontwin.bf.choose configure -state normal
00318 }
00319
00320 ttk::frame .fontwin.bf
00321 ttk::button .fontwin.bf.choose -style BButton -text "Choose" -width 6 -command {
00322 destroy .fontwin
00323 } -state disabled
00324 ttk::button .fontwin.bf.cancel -style BButton -text "Cancel" -width 6 -command {
00325 set ::fontchooser_value ""
00326 destroy .fontwin
00327 }
00328
00329 pack .fontwin.bf.cancel -side right -padx 2 -pady 2
00330 pack .fontwin.bf.choose -side right -padx 2 -pady 2
00331
00332 pack .fontwin.fc -fill both -expand yes
00333 pack .fontwin.bf -fill x
00334
00335 fontchooser::show .fontwin.fc
00336
00337 tkwait window .fontwin
00338
00339 return $::fontchooser_value
00340
00341 }
