font.tcl

# ----------------------------------------------------------------------------
#  font.tcl
#  This file is part of Unifix BWidget Toolkit
#  $Id: font.tcl,v 1.18 2009/11/01 20:20:50 oberdorfer Exp $
# ----------------------------------------------------------------------------
#  Index of commands:
#     - SelectFont::create
#     - SelectFont::configure
#     - SelectFont::cget
#     - SelectFont::_draw
#     - SelectFont::_destroy
#     - SelectFont::_modstyle
#     - SelectFont::_update
#     - SelectFont::_getfont
#     - SelectFont::_init
#     - SelectFont::_themechanged
# ----------------------------------------------------------------------------

namespace eval SelectFont {
    Widget::define SelectFont font Dialog LabelFrame ScrolledWindow

    Widget::declare SelectFont {
        {-title		String		"Font selection" 0}
        {-parent	String		"" 0}
        {-foreground       Color        "SystemWindowText"    0}
        {-background       Color        "SystemWindow"        0}
        {-selectbackground Color        "SystemHighlight"     0}
        {-selectforeground Color        "SystemHighlightText" 0}
        {-type		Enum		dialog        0 {dialog toolbar}}
        {-font		TkResource	""            0 label}
	{-initialcolor	String		""            0}
	{-families	String		"all"         1}
	{-querysystem	Boolean		1             0}
	{-nosizes	Boolean		0             1}
	{-styles	String		"bold italic underline overstrike" 1}
        {-command	String		""            0}
        {-sampletext	String		"Sample Text" 0}
        {-bg		Synonym		-background}
    }

    variable _families
    variable _styleOff
    array set _styleOff [list bold normal italic roman]
    variable _sizes     {4 5 6 7 8 9 10 11 12 13 14 15 16 \
	    17 18 19 20 21 22 23 24}
    
    # Set up preset lists of fonts, so the user can avoid the painfully slow
    # loadfont process if desired.
    if { [string equal $::tcl_platform(platform) "windows"] } {
	set presetVariable [list	\
		7x14			\
		Arial			\
		{Arial Narrow}		\
		{Lucida Sans}		\
		{MS Sans Serif}		\
		{MS Serif}		\
		{Times New Roman}	\
		]
	set presetFixed    [list	\
		6x13			\
		{Courier New}		\
		FixedSys		\
		Terminal		\
		]
	set presetAll      [list	\
		6x13			\
		7x14			\
		Arial			\
		{Arial Narrow}		\
		{Courier New}		\
		FixedSys		\
		{Lucida Sans}		\
		{MS Sans Serif}		\
		{MS Serif}		\
		Terminal		\
		{Times New Roman}	\
		]
    } else {
	set presetVariable [list	\
		helvetica		\
		lucida			\
		lucidabright		\
		{times new roman}	\
		]
	set presetFixed    [list	\
		courier			\
		fixed			\
		{lucida typewriter}	\
		screen			\
		serif			\
		terminal		\
		]
	set presetAll      [list	\
		courier			\
		fixed			\
		helvetica		\
		lucida			\
		lucidabright		\
		{lucida typewriter}	\
		screen			\
		serif			\
		terminal		\
		{times new roman}	\
		]
    }
    array set _families [list \
	    presetvariable	$presetVariable	\
	    presetfixed		$presetFixed	\
	    presetall		$presetAll	\
	    ]

    if {[lsearch [bindtags .] SelectFontThemeChanged] < 0} {
        bindtags . [linsert [bindtags .] 1 SelectFontThemeChanged]
    }

    variable _widget
}


# ----------------------------------------------------------------------------
#  Command SelectFont::create
# ----------------------------------------------------------------------------
proc SelectFont::create { path args } {
    variable _families
    variable _sizes
    variable $path
    upvar 0  $path data

    # Initialize the internal rep of the widget options
    Widget::init SelectFont "$path#SelectFont" $args

    if { [Widget::getoption "$path#SelectFont" -querysystem] } {
        loadfont [Widget::getoption "$path#SelectFont" -families]
    }

    set bg [Widget::getoption "$path#SelectFont" -background]
    set _styles [Widget::getoption "$path#SelectFont" -styles]
    if { [Widget::getoption "$path#SelectFont" -type] == "dialog" } {

        Dialog::create $path -modal local -anchor e -default 0 -cancel 1 \
                -title  [Widget::getoption "$path#SelectFont" -title] \
                -parent [Widget::getoption "$path#SelectFont" -parent]

        $path configure -background $bg

        set frame [Dialog::getframe $path]

        set topf  [frame \
	               $frame.topf -relief flat -borderwidth 0 \
		       -background $bg]

        set labf1 [LabelFrame::create $topf.labf1 -text "Font" -name font \
                       -side top -anchor w -relief flat -background $bg]
        set sw    [ScrolledWindow::create [LabelFrame::getframe $labf1].sw \
                       -background $bg]
        set lbf   [listbox $sw.lb \
                       -height 5 -width 25 \
		       -exportselection false -selectmode browse \
                       -foreground $BWidget::colors(SystemWindowText) \
		       -background $BWidget::colors(SystemWindow) \
                       -selectforeground $BWidget::colors(SystemHighlightText) \
		       -selectbackground $BWidget::colors(SystemHighlight)]

        ScrolledWindow::setwidget $sw $lbf
        LabelFrame::configure $labf1 -focus $lbf
	if { [Widget::getoption "$path#SelectFont" -querysystem] } {
	    set fam [Widget::getoption "$path#SelectFont" -families]
	} else {
	    set fam "preset"
	    append fam [Widget::getoption "$path#SelectFont" -families]
	}
        eval [list $lbf insert end] $_families($fam)
        set script "set [list SelectFont::${path}(family)] \[%W curselection\];\
		        SelectFont::_update [list $path]"
        bind $lbf <ButtonRelease-1> $script
        bind $lbf <space>           $script
	bind $lbf <1>               [list focus %W]
	bind $lbf <Up> $script
	bind $lbf <Down> $script
        pack $sw -fill both -expand yes

        set labf2 [LabelFrame::create $topf.labf2 -text "Size" -name size \
                       -side top -anchor w -relief flat -background $bg]
        set sw    [ScrolledWindow::create [LabelFrame::getframe $labf2].sw \
                       -scrollbar vertical -background $bg]
        set lbs   [listbox $sw.lb \
                       -height 5 -width 6 -exportselection false \
		       -selectmode browse \
                       -foreground $BWidget::colors(SystemWindowText) \
		       -background $BWidget::colors(SystemWindow) \
                       -selectforeground $BWidget::colors(SystemHighlightText) \
		       -selectbackground $BWidget::colors(SystemHighlight)]

        ScrolledWindow::setwidget $sw $lbs
        LabelFrame::configure $labf2 -focus $lbs
        eval [list $lbs insert end] $_sizes
        set script "set [list SelectFont::${path}(size)] \[%W curselection\];\
			SelectFont::_update [list $path]"
        bind $lbs <ButtonRelease-1> $script
        bind $lbs <space>           $script
	bind $lbs <1>               [list focus %W]
	bind $lbs <Up> $script
	bind $lbs <Down> $script
        pack $sw -fill both -expand yes

        set labf3 [LabelFrame::create $topf.labf3 -text "Style" -name style \
                       -side top -anchor w -relief sunken -bd 1 -background $bg]
        set subf  [LabelFrame::getframe $labf3]
        foreach st $_styles {
            set name [lindex [BWidget::getname $st] 0]
            if { $name == "" } {
                set name [string toupper $name 0]
            }

            if { [BWidget::using ttk] } {
                ttk::checkbutton $subf.$st -text $name \
                    -variable   SelectFont::$path\($st\) \
                    -command    [list SelectFont::_update $path]
            } else {
                checkbutton $subf.$st -text $name \
                    -variable   SelectFont::$path\($st\) \
                    -background $bg \
                    -command    [list SelectFont::_update $path]
	    }

            bind $subf.$st <Return> break
            pack $subf.$st -anchor w -padx 5
        }
        LabelFrame::configure $labf3 -focus $subf.[lindex $_styles 0]

        pack $labf1 -side left -anchor n -fill both -expand yes
	if { ![Widget::getoption "$path#SelectFont" -nosizes] } {
	        pack $labf2 -side left -anchor n -fill both -expand yes -padx 8
	}
        pack $labf3 -side left -anchor n -fill both -expand yes

        set botf [frame $frame.botf -width 100 -height 50 \
                      -bg white -bd 0 -relief flat \
                      -highlightthickness 1 -takefocus 0 \
                      -background $BWidget::colors(SystemWindow) \
                      -highlightbackground $BWidget::colors(SystemWindowText) \
		      -highlightcolor $BWidget::colors(SystemWindowText)]

        set lab  [label $botf.label \
                      -foreground $BWidget::colors(SystemWindowText) \
                      -background $BWidget::colors(SystemWindow) \
                      -borderwidth 0 -takefocus 0 -highlightthickness 0 \
                      -text [Widget::getoption "$path#SelectFont" -sampletext]]
        place $lab -relx 0.5 -rely 0.5 -anchor c

	pack $topf -pady 4 -fill both -expand yes

	if { [Widget::getoption "$path#SelectFont" -initialcolor] != ""} {
		set thecolor [Widget::getoption "$path#SelectFont" -initialcolor]

                set colf [frame $frame.colf]
                set frc [frame $colf.frame -width 50 -height 20 -bg $thecolor -bd 0 -relief flat\
			-highlightthickness 1 -takefocus 0 \
			-highlightbackground black \
			-highlightcolor black]

		set script "set [list SelectFont::${path}(fontcolor)] \
		              \[SelectColor::dialog $colf.coldlg -parent $colf.button \
			          -color \[set [list SelectFont::${path}(fontcolor)]\]\]; \
			    SelectFont::_update [list $path]"
		
		set but  [Button $colf.button -command $script \
			     -text "Color..."]

		$lab configure -foreground $thecolor
		$frc configure -bg $thecolor
		
		pack $but -side left
		pack $frc -side left -padx 5
		
		set data(frc) $frc
		set data(fontcolor) $thecolor

		pack $colf -pady 4 -fill x -expand true        
	
	} else {
		set data(fontcolor) -1
	}
	pack $botf -pady 4 -fill x

        Dialog::add $path -name ok
        Dialog::add $path -name cancel

        set data(label) $lab
        set data(lbf)   $lbf
        set data(lbs)   $lbs

        _getfont $path

	Widget::create SelectFont $path 0

        return [_draw $path]
    } else {
	if { [Widget::getoption "$path#SelectFont" -querysystem] } {
	    set fams [Widget::getoption "$path#SelectFont" -families]
	} else {
	    set fams "preset"
	    append fams [Widget::getoption "$path#SelectFont" -families]
	}
	if { [BWidget::using ttk] } {
	    ttk::frame $path
	    set lbf [ttk::combobox $path.font \
			 -takefocus 0 -exportselection 0 \
			 -values   $_families($fams) \
			 -textvariable SelectFont::${path}(family) \
			 -state readonly]
	    set lbs [ttk::combobox $path.size \
			 -takefocus 0 -exportselection 0 \
			 -width    4 \
			 -values   $_sizes \
			 -textvariable SelectFont::${path}(size) \
			 -state readonly]
	    bind $lbf <<ComboboxSelected>> [list SelectFont::_update $path]
	    bind $lbs <<ComboboxSelected>> [list SelectFont::_update $path]
	} else {
	    frame $path -background $bg
	    set lbf [ComboBox::create $path.font \
			 -highlightthickness 0 -takefocus 0 -background $bg \
			 -values   $_families($fams) \
			 -textvariable SelectFont::$path\(family\) \
			 -editable 0 \
			 -modifycmd [list SelectFont::_update $path] \
			 -hottrack 1]
	    set lbs [ComboBox::create $path.size \
			 -highlightthickness 0 -takefocus 0 -background $bg \
			 -width    4 \
			 -values   $_sizes \
			 -textvariable SelectFont::$path\(size\) \
			 -editable 0 \
			 -modifycmd [list SelectFont::_update $path] \
			 -hottrack 1]
	}
	bind $path <Destroy> [list SelectFont::_destroy $path]
        pack $lbf -side left -anchor w
        pack $lbs -side left -anchor w -padx 4
        foreach st $_styles {
	    if { [BWidget::using ttk] } {
		ttk::checkbutton $path.$st -takefocus 0 \
		    -image [Bitmap::get $st] \
		    -variable SelectFont::${path}($st) \
		    -command [list SelectFont::_update $path] \
		    -style [Button::getSlimButtonStyle]
	    } else {
		button $path.$st \
		    -highlightthickness 0 -takefocus 0 -padx 0 -pady 0 \
		    -background $bg \
		    -image [Bitmap::get $st] \
		    -command [list SelectFont::_modstyle $path $st]
	    }
            pack $path.$st -side left -anchor w
        }
        set data(label) ""
        set data(lbf)   $lbf
        set data(lbs)   $lbs
        _getfont $path

        bind SelectFontThemeChanged <<ThemeChanged>> \
	        "+ [namespace current]::_themechanged $path"

	return [Widget::create SelectFont $path]
    }

    return $path
}


# ----------------------------------------------------------------------------
#  Command SelectFont::configure
# ----------------------------------------------------------------------------
proc SelectFont::configure { path args } {
    set _styles [Widget::getoption "$path#SelectFont" -styles]

    set res [Widget::configure "$path#SelectFont" $args]

    if { [Widget::hasChanged "$path#SelectFont" -font font] } {
        _getfont $path
    }
    if { [Widget::hasChanged "$path#SelectFont" -background bg] } {
        switch -- [Widget::getoption "$path#SelectFont" -type] {
            dialog {
                Dialog::configure $path -background $bg
                set topf [Dialog::getframe $path].topf
                $topf configure -background $bg
                foreach labf {labf1 labf2} {
                    LabelFrame::configure $topf.$labf -background $bg
                    set subf [LabelFrame::getframe $topf.$labf]
                    ScrolledWindow::configure $subf.sw -background $bg
                    $subf.sw.lb configure -background $bg
                }
                LabelFrame::configure $topf.labf3 -background $bg
                set subf [LabelFrame::getframe $topf.labf3]
                foreach w [winfo children $subf] {
                    $w configure -background $bg
                }
            }
            toolbar {
                if { ![BWidget::using ttk] } {
                    $path:cmd configure -background $bg
                    ComboBox::configure $path.font -background $bg
                    ComboBox::configure $path.size -background $bg
                    foreach st $_styles {
                        $path.$st configure -background $bg
                    }
		}
            }
        }
    }
    return $res
}


# ----------------------------------------------------------------------------
#  Command SelectFont::cget
# ----------------------------------------------------------------------------
proc SelectFont::cget { path option } {
    return [Widget::cget "$path#SelectFont" $option]
}


# ----------------------------------------------------------------------------
#  Command SelectFont::loadfont
# ----------------------------------------------------------------------------
proc SelectFont::loadfont {{which all}} {
    variable _families

    # initialize families
    if {![info exists _families(all)]} {
	set _families(all) [lsort -dictionary [font families]]
    }
    if {[regexp {fixed|variable} $which] \
	    && ![info exists _families($which)]} {
	# initialize families
	set _families(fixed) {}
	set _families(variable) {}
	foreach family $_families(all) {
	    if { [font metrics [list $family] -fixed] } {
		lappend _families(fixed) $family
	    } else {
		lappend _families(variable) $family
	    }
	}
    }
    return
}


# ----------------------------------------------------------------------------
#  Command SelectFont::_draw
# ----------------------------------------------------------------------------
proc SelectFont::_draw { path } {
    variable $path
    upvar 0  $path data

    $data(lbf) selection clear 0 end
    $data(lbf) selection set $data(family)
    $data(lbf) activate $data(family)
    $data(lbf) see $data(family)
    $data(lbs) selection clear 0 end
    $data(lbs) selection set $data(size)
    $data(lbs) activate $data(size)
    $data(lbs) see $data(size)
    _update $path

    if { [Dialog::draw $path] == 0 } {
        set result [Widget::getoption "$path#SelectFont" -font]
    	set color $data(fontcolor)
	
	if { $color == "" } {
		set color #000000
	}

    } else {
        set result ""
        if {$data(fontcolor) == -1} {
            set color -1
        } else {
            set color ""
        }
    }
    unset data
    Widget::destroy "$path#SelectFont"
    destroy $path
    if { $color != -1 } {
    	return [list $result $color]
    } else {
    	return $result
    }
}


# ----------------------------------------------------------------------------
#  Command SelectFont::_modstyle
# ----------------------------------------------------------------------------
proc SelectFont::_modstyle { path style } {
    variable $path
    upvar 0  $path data

    $path.$style configure -relief [expr {$data($style) ? "raised" : "sunken"}]
    set data($style) [expr {!$data($style)}]
    _update $path
}


# ----------------------------------------------------------------------------
#  Command SelectFont::_update
# ----------------------------------------------------------------------------
proc SelectFont::_update { path } {
    variable _families
    variable _sizes
    variable _styleOff
    variable $path
    upvar 0  $path data

    set type [Widget::getoption "$path#SelectFont" -type]
    set _styles [Widget::getoption "$path#SelectFont" -styles]
    if { [Widget::getoption "$path#SelectFont" -querysystem] } {
	set fams [Widget::getoption "$path#SelectFont" -families]
    } else {
	set fams "preset"
	append fams [Widget::getoption "$path#SelectFont" -families]
    }
    if { $type == "dialog" } {
        set curs [$path:cmd cget -cursor]
        $path:cmd configure -cursor watch
    }
    if { [Widget::getoption "$path#SelectFont" -type] == "dialog" } {
        set font [list [lindex $_families($fams) $data(family)] \
		[lindex $_sizes $data(size)]]
    } else {
        set font [list $data(family) $data(size)]
    }
    foreach st $_styles {
        if { $data($st) } {
            lappend font $st
        } elseif {[info exists _styleOff($st)]} {
	    # This adds the default bold/italic value to a font
	    #lappend font $_styleOff($st)
	}
    }
    Widget::setoption "$path#SelectFont" -font $font
    if { $type == "dialog" } {
        $data(label) configure -font $font
        $path:cmd configure -cursor $curs
	if { ($data(fontcolor) != "") && ($data(fontcolor) != -1) } {
		$data(label) configure -foreground $data(fontcolor)
		$data(frc) configure -bg $data(fontcolor)
	} elseif { $data(fontcolor) == "" }  {
		#If no color is selected, restore previous one
		set data(fontcolor) [$data(label) cget -foreground]

	}
    } elseif { [set cmd [Widget::getoption "$path#SelectFont" -command]] != "" } {
        uplevel \#0 $cmd
    }
}


# ----------------------------------------------------------------------------
#  Command SelectFont::_getfont
# ----------------------------------------------------------------------------
proc SelectFont::_getfont { path } {
    variable _families
    variable _sizes
    variable $path
    upvar 0  $path data

    array set font [font actual [Widget::getoption "$path#SelectFont" -font]]
    set data(bold)       [expr {![string equal $font(-weight) "normal"]}]
    set data(italic)     [expr {![string equal $font(-slant)  "roman"]}]
    set data(underline)  $font(-underline)
    set data(overstrike) $font(-overstrike)
    set _styles [Widget::getoption "$path#SelectFont" -styles]
    if { [Widget::getoption "$path#SelectFont" -querysystem] } {
	set fams [Widget::getoption "$path#SelectFont" -families]
    } else {
	set fams "preset"
	append fams [Widget::getoption "$path#SelectFont" -families]
    }
    if { [Widget::getoption "$path#SelectFont" -type] == "dialog" } {
        set idxf [lsearch $_families($fams) $font(-family)]
        set idxs [lsearch $_sizes    $font(-size)]
        set data(family) [expr {$idxf >= 0 ? $idxf : 0}]
        set data(size)   [expr {$idxs >= 0 ? $idxs : 0}]
    } else {
	set data(family) $font(-family)
	set data(size)   $font(-size)
	if { ![BWidget::using ttk] } {
	    foreach st $_styles {
		$path.$st configure \
		    -relief [expr {$data($st) ? "sunken":"raised"}]
	    }
	}
    }
}


# ----------------------------------------------------------------------------
#  Command SelectFont::_destroy
# ----------------------------------------------------------------------------
proc SelectFont::_destroy { path } {
    variable $path
    upvar 0  $path data
    unset data
    Widget::destroy "$path#SelectFont"
}

# ----------------------------------------------------------------------------
#  Command SelectFont::_themechanged
# ----------------------------------------------------------------------------
proc SelectFont::_themechanged { path } {
    if { ![winfo exists $path] } { return }
    BWidget::set_themedefaults
    $path configure -background $BWidget::colors(SystemWindowFrame)
}