Font chooser / font selection dialog

# ------------------------------------------------------------------------
# fontseldialog_test.tcl ---
# ------------------------------------------------------------------------
# (c) 2016, Johann Oberdorfer - Engineering Support | CAD | Software
#     johann.oberdorfer [at] gmail.com
#     www.johann-oberdorfer.eu
# ------------------------------------------------------------------------
# This source file is distributed under the BSD license.
#   This program is distributed in the hope that it will be useful,
#   but WITHOUT ANY WARRANTY; without even the implied warranty of
#   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
#   See the BSD License for more details.
# ------------------------------------------------------------------------
# Purpose:
#  This file belongs to the fontseldialog.tcl widget
# ------------------------------------------------------------------------

set dir [file dirname [info script]]

set auto_path [linsert $auto_path 0 [file join $dir "."]]
set auto_path [linsert $auto_path 0 [file join $dir ".."]]
set auto_path [linsert $auto_path 0 [file join $dir "../../lib"]]


# test-run ...

package require Tk
package require tile

package require -exact tablelist_tile 6.1
package require fontseldialog 0.1


wm withdraw .

set showconsole 0
if { $showconsole && $::tcl_platform(platform) == "windows"} {
	console show
	console eval {wm protocol . WM_DELETE_WINDOW {exit 0}}
}

set rval [fontseldialog::fontseldialog \
			-parent "" \
			-title  "Select Font Style:" \
			-font   "Comic Sans MS" \
		]

puts "Selection return value is: \"$rval\""

# ------------------------------------------------------------------------
# fontseldialog.tcl ---
# ------------------------------------------------------------------------
# (c) 2017, Johann Oberdorfer - Engineering Support | CAD | Software
#     johann.oberdorfer [at] gmail.com
#     www.johann-oberdorfer.eu
# ------------------------------------------------------------------------
# This source file is distributed under the BSD license.
#   This program is distributed in the hope that it will be useful,
#   but WITHOUT ANY WARRANTY; without even the implied warranty of
#   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
#   See the BSD License for more details.
# ------------------------------------------------------------------------
# Purpose:
#   Create a tableview and show the available font styles
#   in 2 columss name / fixed font / formatted_text...
# ------------------------------------------------------------------------

# ... auf der Suche nach einer vollendeten Einheit
#     von Material, Form und Funktion ...
#

# package require Tk
# package require -exact tablelist_tile 6.1

package provide fontseldialog 0.1


namespace eval fontseldialog {

	variable widgetDefaults
	variable widgetImages
	variable widgetVars

	array set widgetDefaults {
		wparent ""
		title "Font Selection Dialog"
		font ""
	}

	# initializing required images...
	set this_dir   [file dirname [info script]]
	set image_dir  [file join $this_dir "images"]
	set image_file [file join $this_dir "ImageLib.tcl"]

	proc LoadImages {image_dir {patterns {*.gif}}} {
		foreach p $patterns {
			foreach file [glob -nocomplain -directory $image_dir $p] {
				set img [file tail [file rootname $file]]
				if { ![info exists images($img)] } {
					set images($img) [image create photo -file $file]
				}
			}}
		return [array get images]
	}

	if { [file exists $image_file] } {
		source $image_file
		array set widgetImages [array get images]
	} else {
		array set widgetImages [LoadImages \
				[file join $image_dir] {"*.gif" "*.png"}]
	}

	proc GetFontInformation {} {
		variable widgetDefaults
		variable widgetVars

		# make shure to create fonts + data list only once
		if {[info exists widgetVars(font_info)] &&
			[llength $widgetVars(font_info)] > 0} {
			
			return $widgetVars(font_info)
		}

		set widgetVars(font_info) [list]
	
		foreach font [lsort -dictionary [font families]] {
		
			# top and bottom spacing for this font is very big,
			# so let's filter out this specific font:
			if {$font == "Cambria Math"} { continue }
			
			set fid [font create -family $font]
			
			set fmetrics ""
			if {[font metrics $fid -fixed]} {
				set fmetrics "*"
			}
		
			lappend widgetVars(font_info) \
				[list [string trim $font] $fmetrics $widgetDefaults(sampletxt) $fid]
		}

		return $widgetVars(font_info)
	}

	proc ShowFont {fname fid} {
		variable widgetVars
		wm title $widgetVars(this) "Font selection dialog - $fname"
		# $widgetVars(wlabel) configure -font $fid
	}
	
	proc CancelCmd {} {
		variable widgetVars
		set widgetVars(is_ok) 2
	}
	
	proc OKButtonCmd {} {
		variable widgetVars
		set widgetVars(is_ok) 1
	}
	
	proc EnableOkButtonCmd {} {
		variable widgetVars		
		$widgetVars(ok_button) configure -state normal
	}

	proc DisableOkButtonCmd {} {
		variable widgetVars
		$widgetVars(ok_button) configure -state disabled
	}
	
		
	proc EntryBindingsCmd {tbl {mode "default"}} {
		variable widgetDefaults
		variable widgetVars
		
		switch -- $mode {
			"default" {
				set widgetVars(combobox_var) ""
				set searchtxt [string trim $widgetVars(entry_var)]				
				# if {$searchtxt == "" } { return }
			}
			"refresh" {
				# force refresh
				set widgetVars(entry_var) ""
				set widgetVars(combobox_var) ""
				set searchtxt ""
			}
			"combo" {
				set widgetVars(entry_var) ""
				set searchtxt [string trim $widgetVars(combobox_var)]
			}
			default {
				return -code error \
					"programmer's error: unknown $mode in proc EntryBindingsCmd"
			}
		}

		$tbl selection clear 0 end
		$tbl delete 0 end

		set idx 0
		foreach item [GetFontInformation] {
			set font [lindex $item 0]
			set fid [lindex $item end]

			if { $searchtxt == "" || \
				 [string first $searchtxt $font] != -1} {
			
				$tbl insert end $item
				$tbl cellconfigure "$idx,2" -font $fid
				incr idx
			}
		}
		
		$widgetVars(wstatus_label) configure -text \
			"There are $idx fonts available."

		DisableOkButtonCmd
	}

	proc TextSearch {w string tag} {
		$w tag remove $tag 0.0 end
		if {$string == ""} {
			return
		}
		set cur 0.0
		while 1 {
			set cur [$w search -count length $string $cur end]
			if {$cur == ""} {
				break
			}
			$w tag add $tag $cur "$cur + $length char"
			set cur [$w index "$cur + $length char"]
		}
	}
	
	# recursive function
	proc WinfoGetAllTextWidgets {wparent wlist} {
		upvar $wlist widget_list 
	
		foreach w [winfo children $wparent] {
			if { [winfo class $w] == "Text" } {
				lappend widget_list $w
			}
			WinfoGetAllTextWidgets $w widget_list
		}
	}

	proc ColorizeCmd {tbl textWidget key row col tabIdx1 tabIdx2 inStripe selected} {
		variable widgetVars
		
		if {! [info exists widgetVars(entry_var)] ||
			  [winfo class $textWidget] != "Text" } {
			return
		}
		
		
		# -development-
		# set wtext_list [list]
		# WinfoGetAllTextWidgets $tbl wtext_list
		# puts "There are [llength $wtext_list] text widgets available."
		# foreach wtext $wtext_list { puts $wtext }
		
		set searchtxt [string trim $widgetVars(entry_var)]
		
		if {[string length $searchtxt] <= 1}  {
			return
		}
		
		# #ce5555 / White
		$textWidget tag configure search \
			-background LightYellow -foreground Black
		
		TextSearch $textWidget $searchtxt search
	}

	proc ComboBoxSelectedCmd {tbl w} {
		EntryBindingsCmd $tbl "combo"
	}

	# -------------------------------------------------------------------------
	# gui declaration
	# -------------------------------------------------------------------------
	
	proc fontseldialog {args} {
		variable widgetDefaults
		variable widgetImages
		variable widgetVars
		
		# "AaBbCcDdEeFfGgHhIi 1234567890 .,+-:*?!"
		# "The quick brown fox jumps over the lazy dog."
		# "entia non sunt multiplicanda praeter necessitatem"
		#  - (use) no more things than necessary"
		# If two things do the same job, simpler is better.

		array set widgetDefaults {
			sampletxt "Entia non sunt multiplicanda praeter necessitatem."
		}
	
		set ind 0
		while { $ind < [llength $args] } {
			switch -exact -- [lindex $args $ind] {
				"-parent" {
					incr ind
					set widgetDefaults(wparent) [lindex $args $ind]
					incr ind
				}
				"-title" {
					incr ind
					set widgetDefaults(title) [lindex $args $ind]
					incr ind
				}
				"-font" {
					incr ind
					set widgetDefaults(font) [lindex $args $ind]
					incr ind
				}
				default {
					puts "unknown option [lindex $args $ind]"
					return ""
				}
			}
		}
		
		set w $widgetDefaults(wparent).fontseldialog
		set widgetVars(this) $w
		catch {destroy $w}
		
		toplevel $w -class FontSelDialog
		wm title $w widgetDefaults(title)
		wm geometry $w "800x650+150+150"
		wm transient $w $widgetDefaults(wparent)
		bind $w <KeyPress-Escape> "[namespace current]::CancelCmd"
		
		set fmain [ttk::frame $w.main -relief groove]
		pack $fmain -side bottom -fill x
		
		ttk::button $fmain.chk \
				-text "Continue with selected font..." \
				-compound left \
				-image $widgetImages(dialog-ok) \
				-command "[namespace current]::OKButtonCmd" \
				-state disabled
		
		set widgetVars(ok_button) $fmain.chk
		
		ttk::button $fmain.cancel \
				-text "Cancel" \
				-image $widgetImages(dialog-close) \
				-compound left \
				-command "[namespace current]::CancelCmd" \
				
		pack $fmain.chk $fmain.cancel -side left -expand true -padx 4 -pady 4
		
		# --------------------------
		# font selection gui
		# --------------------------

		set f [ttk::frame $w.help -height 20]
		pack $f -side bottom -fill x
		
		set widgetVars(wlabelframe) $f
		
		set msg "Hint: You might want to use one of the \"UI\" font styles"
		append msg "\nwhich are easy to read and look good for user interfaces."
	
		ttk::label $f.lbl -text $msg
		pack $f.lbl -anchor center
		
		set widgetVars(wlabel) $f.lbl
		
		set f [ttk::frame $w.entry]
		pack $f -side top -fill x

		ttk::label $f.lcombo -text "Filter: "
		ttk::combobox $f.combo \
			-width 5 -state readonly \
			-values [list "" "ExtB" "FB" "MS" "MT" "Sans" "UI" "Hand" "Script" "Light"] \
			-textvariable "[namespace current]::widgetVars(combobox_var)"

		set widgetVars(wcombobox) $f.combo
			
		ttk::label $f.lbl \
			-image $widgetImages(dialog-search)
		
		ttk::entry $f.entry \
			-width 40 \
			-textvariable "[namespace current]::widgetVars(entry_var)"

		set widgetVars(wentry) $f.entry

		ttk::button $f.bttn \
				-compound left \
				-image $widgetImages(dialog-refresh) \
				-style Toolbutton

		set widgetVars(wentry_bttn) $f.bttn
				
		pack $f.lcombo $f.combo $f.lbl -side left -padx 5 -pady 5
		pack $f.entry -side left -padx 5 -pady 5 -fill x -expand true
		pack $f.bttn -side left -padx 2
		
		set tf $w.tf
		ttk::frame $tf
		set tbl $tf.tbl
		set vsb $tf.vsb
		
		tablelist::tablelist $tbl \
				-columns {
					0 "Font Name"	left
					0 "fixed" center
					0 "Sample text" left
					0 "Font ID" right } \
				-labelcommand tablelist::sortByColumn \
				-yscrollcommand [list $vsb set] -width 0 \
				-spacing 1 \
				-showseparators yes \
				-selectmode single \
				-font APP_FONT_STD_NORMAL \
				-stripebackground #E0E8F0 \
				-selectbackground #A9D0F5 \
				-stretch all \
				-spacing 2
				
		$tbl configure -colorizecommand "[namespace current]::ColorizeCmd"
		$tbl columnconfigure end -hide yes
				
		ttk::scrollbar $vsb -orient vertical -command [list $tbl yview]
		
		grid $tbl -row 0 -rowspan 2 -column 0 -sticky news
		grid $vsb -row 0 -rowspan 2 -column 1 -sticky ns
		
		grid rowconfigure    $tf 1 -weight 1
		grid columnconfigure $tf 0 -weight 1
		pack $tf -side top -expand yes -fill both


		set f [ttk::frame $w.status]
		pack $f -side top -fill x

		ttk::label $f.status
		# -image $widgetImages(dialog-search)
		
		set widgetVars(wstatus_label) $f.status

		pack $f.status -anchor center -padx 5 -pady 5
		
		bind [$tbl bodypath] <Motion> {+
			set t [winfo parent %W]
			set x [expr {%x + [winfo x %W]}]
			set y [expr {%y + [winfo y %W]}]
			
			# enable move-over effect,
			focus $t
			$t configure -activestyle frame
			$t activate "@$x,$y"
			
			::fontseldialog::ShowFont \
				[lindex [$t get "@$x,$y"] 0] \
				[lindex [$t get "@$x,$y"] end]
		}

		bind [$tbl bodypath] <Leave> {
			set t [winfo parent %W]
			$t configure -activestyle none
		}		
		
		bind [$tbl bodypath] <ButtonPress-2> {
			[winfo parent %W] configure -cursor "hand2"
		}
		bind [$tbl bodypath] <ButtonRelease-2> {
			[winfo parent %W] configure -cursor ""
		}
		
		bind [$tbl bodypath] <ButtonRelease-1> {
			set t [winfo parent %W]
			set x [expr {%x + [winfo x %W]}]
			set y [expr {%y + [winfo y %W]}]
		
			# if a tablelist has only a few entries, an "empty area"
			# is shown after the last row 
			# the following if clause ensures that a click in
			# this area simply has no effect
			set row [lindex [split [$t containingcell $x $y] ","] 0]
			if {$row == -1} {
				::fontseldialog::DisableOkButtonCmd
			} else {
				set cell [$t nearestcell $x $y]
				::fontseldialog::EnableOkButtonCmd
			}
		}

		bind [$tbl bodypath] <Double-ButtonPress-1> "[namespace current]::OKButtonCmd"
		
		bind $widgetVars(wentry) \
			<KeyRelease> "[namespace current]::EntryBindingsCmd $tbl"
		$widgetVars(wentry_bttn) configure \
			-command "[namespace current]::EntryBindingsCmd $tbl refresh"

		bind $widgetVars(wcombobox) <<ComboboxSelected>> \
			"[namespace current]::ComboBoxSelectedCmd $tbl %W"
	
		# ---------------------------
		# fill tablelist with content
		# ---------------------------

		set default [lindex [$tbl configure -font] 3]
		
		set idx 0
		foreach item [GetFontInformation] {
			set font [lindex $item 0]
			set fid [lindex $item end]
			
			$tbl insert end $item
			$tbl cellconfigure "$idx,2" -font $fid
			incr idx
		}
		
		$widgetVars(wstatus_label) configure -text \
			"There are $idx fonts available."

		# perform font name preselection (if any)
		# ---------------------------------------

		if { $widgetDefaults(font) != ""} {
		
			# try to find font name and calculate index
			set data [list]
			foreach litem [$tbl get 0 end] {
				lappend data [lindex $litem 0]
			}
			
			if { [set idx [lsearch $data $widgetDefaults(font)]] != -1 } {

				# bummer !
				$tbl selection set $idx
				$tbl see [expr {$idx -3}]
				EnableOkButtonCmd
			}
		}
		
		after 6000 "catch {pack forget $widgetVars(wlabelframe)};"

		# --------------------------
		# --------------------------
		
		# wait user
		grab $widgetVars(this)
		tkwait variable "[namespace current]::widgetVars(is_ok)"
		grab release $widgetVars(this)
		
		if { $widgetVars(is_ok) == 1 } {
			# read actual selection:
			set sel [$tbl curselection]
			set retval [string trim [lindex [$tbl get $sel] 0]]
		} else {
			set retval ""
		}

		# clean fonts before leaving the dialog (if that matters)...
		foreach item [GetFontInformation] {
			set fid [lindex $item end]
			
			set widgetVars(font_info) [list]
			catch {font delete $fid}
		}
		
		destroy $widgetVars(this)
		return $retval
	}
}