#! /bin/sh
# \
exec wish8.4 $0 ${1+"$@"} || exec wish $0 ${1+"$@"} || exit 1

namespace eval ::dkfFontSel {

    # Local procedure names (ones that it is a bad idea to refer to
    # outside this namespace/file) are prepended with an apostrophe
    # character.  There are no externally useful variables.

    # First some library stuff that is normally in another namespace

    # Simple (nay, brain-dead) option parser.  Given the list of
    # arguments in arglist and the list of legal options in optlist,
    # parse the options to convert into array values (which are stored
    # in the caller's array named in optarray.  Does not handle errors
    # spectacularly well, and can be replaced by something that does a
    # better job without me feeling to fussed about it!
    proc 'parse_opts {arglist optlist optarray} {
	upvar $optarray options
	set options(foo) {}
	unset options(foo)
	set callername [lindex [info level -1] 0]
	if {[llength $arglist]&1} {
	    return -code error \
		    "Must be an even number of arguments to $callername"
	}
	array set options $arglist
	foreach key [array names options] {
	    if {![string match -?* $key]} {
		return -code error "All parameter keys must start\
			with \"-\", but \"$key\" doesn't"
	    }
	    if {[lsearch -exact $optlist $key] < 0} {
		return -code error "Bad parameter \"$key\""
	    }
	}
    }

    # Capitalise the given word.  Assumes the first capitalisable
    # letter is the first character in the argument.
    proc 'capitalise {word} {
	set cUpper [string toupper [string index $word 0]]
	set cLower [string tolower [string range $word 1 end]]
	return ${cUpper}${cLower}
    }

    # The classic functional operation.  Replaces each element of the
    # input list with the result of running the supplied script on
    # that element.
    proc 'map {script list} {
	set newlist {}
	foreach item $list {
	    lappend newlist [uplevel 1 $script [list $item]]
	}
	return $newlist
    }

    # ----------------------------------------------------------------------
    # Now we start in earnest
    namespace export dkf_chooseFont

    variable Family Helvetica
    variable Size   12
    variable Done   0
    variable Win    {}

    array set Style {
	bold 0
	italic 0
	underline 0
	overstrike 0
    }

    # Get the gap spacing for the frameboxes.  Use a user-specified
    # default if there is one (that is a valid integer) and fall back
    # to measuring/guessing otherwise.
    proc 'get_gap {w} {
	set gap [option get $w lineGap LineGap]
	if {[catch {incr gap 0}]} {
	    # Some cunning font measuring!
	    label $w._testing
	    set font [$w._testing cget -font]
	    set gap [expr {[font metrics $font -linespace]/2+1}]
	    destroy $w._testing
	}
	return $gap
    }


    # Build the user interface (except for the apply button, which is
    # handled by the 'configure_apply procedure...
    proc 'make_UI {w} {
	# Framed regions.  Do this with grid and labels, as that seems
	# to be the most effective technique in practise!
	frame $w.border1 -class DKFChooseFontFrame
	frame $w.border2 -class DKFChooseFontFrame
	frame $w.border3 -class DKFChooseFontFrame
	frame $w.border4 -class DKFChooseFontFrame
	set gap ['get_gap $w]
	grid $w.border1 -row 0 -column 0 -rowspan 4 -columnspan 4 \
		-padx $gap -pady $gap -sticky nsew
	grid $w.border2 -row 0 -column 4 -rowspan 4 -columnspan 3 \
		-padx $gap -pady $gap -sticky nsew
	grid $w.border3 -row 4 -column 0 -rowspan 3 -columnspan 9 \
		-padx $gap -pady $gap -sticky nsew
	grid $w.border4 -row 7 -column 0 -rowspan 3 -columnspan 9 \
		-padx $gap -pady $gap -sticky nsew
	incr gap $gap
	foreach col {0 3 4 6 8} {
	    grid columnconfigure $w $col -minsize $gap
	}
	foreach row {0 3 4 6 7 9} {
	    grid rowconfigure    $w $row -minsize $gap
	}
	grid columnconfigure $w 1 -weight 1
	grid rowconfigure    $w 1 -weight 1
	grid rowconfigure    $w 8 -weight 1


	# Labels for the framed boxes & focus accelerators for their contents
	foreach {subname row col focusWin} {
	    Family 0 1 .family     
	    Style  0 5 .style.sBold
	    Size   4 1 .size.b8    
	    Sample 7 1 .sample.text
	} {
	    set l [label $w.lbl$subname]
	    grid $l -row $row -column $col -sticky w
	    set accel ['get_accel $l]
	    if {[string length $accel]} {
		bind $w <$accel> [list focus $w$focusWin]
	    }
	}


	# Font families
	frame $w.familyBox
	listbox $w.family -exportsel 0 -selectmode browse \
		-xscrollcommand [list $w.familyX set] \
		-yscrollcommand [list $w.familyY set]
	scrollbar $w.familyX -command [list $w.family xview]
	scrollbar $w.familyY -command [list $w.family yview]
	foreach family ['list_families] {
	    $w.family insert end ['map 'capitalise $family]
	}
	grid $w.familyBox -row 1 -column 1 -rowspan 1 -columnspan 2 \
		-sticky nsew
	grid columnconfigure $w.familyBox 0 -weight 1
	grid rowconfigure    $w.familyBox 0 -weight 1
	grid $w.family  $w.familyY -sticky nsew -in $w.familyBox
	grid $w.familyX            -sticky nsew -in $w.familyBox
	bind $w.family <1> [namespace code {'change_family %W [%W nearest %y]}]
	bindtags $w.family [concat [bindtags $w.family] key$w.family]
	bind key$w.family <Key> [namespace code {'change_family %W active %A}]


	# Font styles.
	frame $w.style
	grid $w.style -row 1 -column 5 -sticky news
	grid columnconfigure $w.style 0 -weight 1
	foreach {fontstyle lcstyle row next prev} {
	    Bold      bold       0 Italic    {}
	    Italic    italic     1 Underline Bold
	    Underline underline  2 Strikeout Italic
	    Strikeout overstrike 3 {}        Underline
	} {
	    set b $w.style.s$fontstyle
	    
	    checkbutton $b -variable [namespace current]::Style($lcstyle) \
		    -command [namespace code 'set_font]
	    grid $b -sticky nsew -row $row
	    grid rowconfigure $w.style $row -weight 1
	    if {[string length $next]} {
		bind $b <Down> [list focus $w.style.s$next]
	    }
	    if {[string length $prev]} {
		bind $b <Up> [list focus $w.style.s$prev]
	    }
	    bind $b <Tab>       "[list focus $w.size.b8];break"
	    bind $b <Shift-Tab> "[list focus $w.family ];break"
	    set accel ['get_accel $b]
	    if {[string length $accel]} {
		bind $w <$accel> "focus $b; $b invoke"
	    }
	    bind $b <Return> "$b invoke; break"
	}


	# Size adjustment.  Common sizes with radio buttons, and an
	# entry for everything else.
	frame $w.size
	grid $w.size -row 5 -column 1 -rowspan 1 -columnspan 7 -sticky nsew
	foreach {size row col u d l r} {
	    8  0 0  {} 10 {} 12
	    9  1 0  {} 10 {} 12
	    10 0 1   8 {} {} 14
	    11 1 1   8 {} {} 14
	    12 0 2  {} 14  8 18
	    14 1 2  12 {} 10 24
	    18 0 3  {} 24 12 {}
	    24 1 3  18 {} 14 {}
	} {
	    set b $w.size.b$size
	    radiobutton $b -variable [namespace current]::Size -value $size \
		    -command [namespace code 'set_font]
	    grid $b -row $row -column $col -sticky ew
	    #grid columnconfigure $w.size $col -weight 1
	    if {[string length $u]} {bind $b <Up>    [list focus $w.size.b$u]}
	    if {[string length $d]} {bind $b <Down>  [list focus $w.size.b$d]}
	    if {[string length $l]} {bind $b <Left>  [list focus $w.size.b$l]}
	    if {[string length $r]} {bind $b <Right> [list focus $w.size.b$r]}
	    bind $b <Tab>       "[list focus $w.size.entry ];break"
	    bind $b <Shift-Tab> "[list focus $w.style.sBold];break"
	    set accel ['get_accel $b]
	    if {[string length $accel]} {
		bind $w <$accel> "focus $b; $b invoke"
	    }
	    bind $b <Return> "$b invoke; break"
	}
	entry $w.size.entry -textvariable [namespace current]::Size
	grid $w.size.entry -row 0 -column 4 -rowspan 2 -sticky ew
	grid columnconfigure $w.size 3 -weight 1
	bind $w.size.entry <Return> \
		[namespace code {'set_font;break}]


	# Sample text.  Note that this is editable
	frame $w.sample
	grid $w.sample -row 8 -column 1 -columnspan 7 -sticky nsew
	grid propagate $w.sample 0
	entry $w.sample.text -background [$w.sample cget -background]
	$w.sample.text insert 0 [option get $w.sample.text text Text]
	grid $w.sample.text


	# OK, Cancel and (partially) Apply.  See also 'configure_apply
	frame $w.butnframe
	grid $w.butnframe -row 0 -column 7 -rowspan 4 -columnspan 2 \
		-sticky nsew -pady $gap
	foreach {but code} {
	    ok  0
	    can 1
	} {
	    button $w.butnframe.$but -command \
		    [namespace code [list set Done $code]]
	    pack $w.butnframe.$but -side top -fill x -padx [expr {$gap/2}] \
		    -pady [expr {$gap/2}]
	}
	button $w.butnframe.apl
	bind $w.butnframe.ok <Down> [list focus $w.butnframe.can]
	bind $w.butnframe.can <Up> [list focus $w.butnframe.ok]
    }


    # Convenience proc to get the accelerator for a particular window
    # if the user has given one.  Makes it simpler to get this right
    # everywhere it is needed...
    proc 'get_accel {w} {
	option get $w accelerator Accelerator
    }


    # Called when changing the family.  Sets the family to either be
    # the first family whose name starts with the given character (if
    # char is non-empty and not special) or to be the name of the
    # family at the given index of the listbox.
    proc 'change_family {w index {char {}}} {
	variable Family
	if {[string length $char] && ![regexp {[]*?\\[]} $char]} {
	    set idx [lsearch -glob ['list_families] $char*]
	    if {$idx >= 0} {
		set index $idx
		$w activate $idx
		$w selection clear 0 end
		$w selection anchor $idx
		$w selection set $idx
		$w see $idx
	    }
	}
	set Family [$w get $index]
	##DEBUG
	#wm title [winfo toplevel $w] $Family
	'set_font
    }


    # The apply button runs this script when pressed.
    proc 'do_apply {w script} {
	'set_font
	set font [$w.sample.text cget -font]
	uplevel #0 $script [list $font]
    }


    # Based on whether the supplied script is empty or not, install an
    # apply button into the dialog.  This is not part of 'make_UI
    # since it happens at a different stage of initialisation.
    proc 'configure_apply {w script} {
	set b $w.butnframe.apl
	set binding [list $b invoke]
	if {[string length $script]} {
	    # There is a script, so map the button
	    array set packinfo [pack info $w.butnframe.ok]
	    $b configure -command [namespace code [list 'do_apply $w $script]]
	    pack $b -side top -fill x -padx $packinfo(-padx) \
		    -pady $packinfo(-pady)

	    bind $w.butnframe.can <Down> [list focus $w.butnframe.apl]
	    bind $w.butnframe.apl <Up>   [list focus $w.butnframe.can]

	    # Set up accelerator.  Tricky since we want to force a
	    # systematic match with the underline
	    set uline [$b cget -underline]
	    if {$uline>=0} {
		set uchar [string index [$b cget -text] $uline]
		set uchar [string tolower $uchar]
		bind $w <Meta-$uchar> $binding
	    }

	} else {
	    # No script => no button
	    set manager [winfo manager $b]
	    if {[string length $manager]} {
		$manager forget $b

		# Now we must remove the accelerator!  This is tricky
		# since we don't actually know what it is officially
		# bound to...
		foreach bindseq [bind $w] {
		    if {![string compare [bind $w $bindseq] $binding]} {
			bind $w $bindseq {}
			break
		    }
		}

	    }
	}
    }


    # Set the font on the editor window based on the information in
    # the namespace variables.  Returns a 1 if the operation was a
    # failure and 0 if it iwas a success.
    proc 'set_font {} {
	variable Family
	variable Style
	variable Size
	variable Win

	set styles {}
	foreach style {italic bold underline overstrike} {
	    if {$Style($style)} {
		lappend styles $style
	    }
	}
	if {[catch {
	    expr {$Size+0}
	    if {[llength $styles]} {
		$Win configure -font [list $Family $Size $styles]
	    } else {
		$Win configure -font [list $Family $Size]
	    }
	} s]} {
	    bgerror $s
	    return 1
	}
	return 0
    }


    # Get a sorted lower-case list of all the font families defined on
    # the system.  A canonicalisation of [font families]
    proc 'list_families {} {
	lsort [string tolower [font families]]
    }

    # ----------------------------------------------------------------------

    proc dkf_chooseFont {args} {
	variable Family
	variable Style
	variable Size
	variable Done
	variable Win

	array set options {
	    -parent {}
	    -title {Select a font}
	    -initialfont {}
	    -apply {}
	}
	'parse_opts $args [array names options] options
	switch -exact -- $options(-parent) {
	    . - {} {
		set parent .
		set w .__dkf_chooseFont
	    }
	    default {
		set parent $options(-parent)
		set w $options(-parent).__dkf_chooseFont
	    }
	}
	catch {destroy $w}

	toplevel $w -class DKFChooseFont
	wm title $w $options(-title)
	wm transient $w $parent
	wm iconname $w ChooseFont
	wm group $w $parent
	wm protocol $w WM_DELETE_WINDOW {#}

	if {![string length $options(-initialfont)]} {
	    set options(-initialfont) [option get $w initialFont InitialFont]
	}

	set Win $w.sample.text
	'make_UI $w
	bind $w <Return>  [namespace code {set Done 0}]
	bind $w <Escape>  [namespace code {set Done 1}]
	bind $w <Destroy> [namespace code {set Done 1}]
	focus $w.butnframe.ok

	'configure_apply $w $options(-apply)

	foreach style {italic bold underline overstrike} {
	    set Style($style) 0
	}
	foreach {family size styles} $options(-initialfont) {break}
	set Family $family
	set familyIndex [lsearch -exact ['list_families] \
		[string tolower $family]]
	if {$familyIndex<0} {
	    wm withdraw $w
	    tk_messageBox -type ok -icon warning -title "Bad Font Family" \
		    -message "Font family \"$family\" is unknown.  Guessing..."
	    set family [font actual $options(-initialfont) -family]
	    set familyIndex [lsearch -exact ['list_families] \
		    [string tolower $family]]
	    if {$familyIndex<0} {
		return -code error "unknown font family fallback \"$family\""
	    }
	    wm deiconify $w
	}
	$w.family selection set $familyIndex
	$w.family see $familyIndex
	set Size $size
	foreach style $styles {set Style($style) 1}

	'set_font

	wm withdraw $w
	update idletasks
	if {$options(-parent)==""} {
	    set x [expr {([winfo screenwidth $w]-[winfo reqwidth $w])/2}]
	    set y [expr {([winfo screenheigh $w]-[winfo reqheigh $w])/2}]
	} else {
	    set pw $options(-parent)
	    set x [expr {[winfo x $pw]+
                         ([winfo width $pw]-[winfo reqwidth $w])/2}]
	    set y [expr {[winfo y $pw]+
                         ([winfo heigh $pw]-[winfo reqheigh $w])/2}]
	}
	wm geometry $w +$x+$y
	update idletasks
	wm deiconify $w
	tkwait visibility $w
	vwait [namespace current]::Done
	if {$Done} {
	    destroy $w
	    return ""
	}
	if {['set_font]} {
	    destroy $w
	    return ""
	}
	set font [$Win cget -font]
	destroy $w
	return $font
    }

    # ----------------------------------------------------------------------
    # I normally load these from a file, but I inline them here for portability
    foreach {pattern value} {
	*DKFChooseFont.DKFChooseFontFrame.borderWidth	2
	*DKFChooseFont.DKFChooseFontFrame.relief	ridge


	*DKFChooseFont.lblFamily.text	       Family
	*DKFChooseFont.lblFamily.underline     0
	*DKFChooseFont.lblFamily.accelerator   Control-f

	*DKFChooseFont.lblStyle.text	       Style
	*DKFChooseFont.lblStyle.underline      2
	*DKFChooseFont.lblStyle.accelerator    Control-y

	*DKFChooseFont.lblSize.text	       Size
	*DKFChooseFont.lblSize.underline       2
	*DKFChooseFont.lblSize.accelerator     Control-z

	*DKFChooseFont.lblSample.text	       Sample


	*DKFChooseFont.style.Checkbutton.anchor		w

	*DKFChooseFont.style.sBold.text	       Bold
	*DKFChooseFont.style.sBold.underline   0
	*DKFChooseFont.style.sBold.accelerator Control-b

	*DKFChooseFont.style.sItalic.text      Italic
	*DKFChooseFont.style.sItalic.underline   0
	*DKFChooseFont.style.sItalic.accelerator Control-i

	*DKFChooseFont.style.sUnderline.text   Underline
	*DKFChooseFont.style.sUnderline.underline   0
	*DKFChooseFont.style.sUnderline.accelerator Control-u

	*DKFChooseFont.style.sStrikeout.text   Overstrike
	*DKFChooseFont.style.sStrikeout.underline   0
	*DKFChooseFont.style.sStrikeout.accelerator Control-o


	*DKFChooseFont.Label.padX	       1m
	*DKFChooseFont.Label.padY	       1

	*DKFChooseFont.family.height	       1
	*DKFChooseFont.family.width	       12
	*DKFChooseFont.familyX.orient	       horizontal
	*DKFChooseFont.Scrollbar.takeFocus     0

	*DKFChooseFont.size.b8.text	       8
	*DKFChooseFont.size.b9.text	       9
	*DKFChooseFont.size.b10.text	       10
	*DKFChooseFont.size.b11.text	       11
	*DKFChooseFont.size.b12.text	       12
	*DKFChooseFont.size.b14.text	       14
	*DKFChooseFont.size.b18.text	       18
	*DKFChooseFont.size.b24.text	       24
	*DKFChooseFont.size.Radiobutton.anchor w
	*DKFChooseFont.size.Entry.background   white

	*DKFChooseFont.sample.text.text	       ABCabcXYZxyz123
	*DKFChooseFont.sample.text.takeFocus   0
	*DKFChooseFont.sample.text.highlightThickness 0
	*DKFChooseFont.sample.text.borderWidth 0
	*DKFChooseFont.sample.text.relief      flat
	*DKFChooseFont.sample.text.width       0
	*DKFChooseFont.sample.text.cursor      {}
	*DKFChooseFont.sample.height	       40
	*DKFChooseFont.sample.width	       40

	*DKFChooseFont.butnframe.ok.default    active
	*DKFChooseFont.butnframe.ok.text       OK
	*DKFChooseFont.butnframe.can.default   normal
	*DKFChooseFont.butnframe.can.text      Cancel
	*DKFChooseFont.butnframe.apl.default   normal
	*DKFChooseFont.butnframe.apl.text      Apply
	*DKFChooseFont.butnframe.apl.underline 0
    } {
	option add $pattern $value startupFile
    }
    switch $tcl_platform(platform) {
	windows {
	    option add *DKFChooseFont.initialFont {Arial 12 bold} startupFile
	}
	default {
	    foreach {pattern value} {
		*DKFChooseFont*Button.BorderWidth      1
		*DKFChooseFont*Checkbutton.BorderWidth 1
		*DKFChooseFont*Entry.BorderWidth       1
		*DKFChooseFont*Label.BorderWidth       1
		*DKFChooseFont*Listbox.BorderWidth     1
		*DKFChooseFont*Menu.BorderWidth	       1
		*DKFChooseFont*Menubutton.BorderWidth  1
		*DKFChooseFont*Message.BorderWidth     1
		*DKFChooseFont*Radiobutton.BorderWidth 1
		*DKFChooseFont*Scale.BorderWidth       1
		*DKFChooseFont*Scrollbar.BorderWidth   1
		*DKFChooseFont*Text.BorderWidth	       1
		*DKFChooseFont.Scrollbar.width         10
		*DKFChooseFont.initialFont             {Helvetica 12 bold}
	    } {
		option add $pattern $value startupFile
	    }
	}
    }

}
namespace import ::dkfFontSel::dkf_chooseFont

# Is there anything already set up as a standard command?
if {![info exist tk_chooseFont]} {
    # If not, set ourselves up using an alias
    interp alias {} tk_chooseFont {} ::dkfFontSel::dkf_chooseFont
}

# ----------------------------------------------------------------------
# Stuff for testing the font selector
if {![string compare [info script] $argv0]} {
    wm deiconify .; update
    # use after idle here to put errors into a dialog for testing...
    after idle {puts [dkf_chooseFont -apply puts]}
}
