# -*- tcl -*- 

#################################################################
# when Tk can handle "emoji" fonts, remove that exception if the
# Tk version is high enough.
#################################################################

# This code pops up a font choose window.  
# You need to do some prep prior to calling...
#
# set FontList [list <your font names>]  e.g. set FontList {ListBoxFont GuiFont}
# set WhichFontToSet <one of the above>
#
# You may also set up an array for each font with the following entries:
#
# set FontInfos(<font name>,help) "Tool tip help string" .e.g. "font used in.."
# set FontInfos(<font name>,fg) foreground color for this font
# set FontInfos(<font name>,bg) background color for this font
# set FontInfos(<font name>,gloss) "string to use a label to select this font"

# then call: fontsel::CreateFontControlPanel

#Font stuff begins here
# Default defaults

set FontInfo(family) courier
set FontInfo(size) 12
set FontInfo(weight) normal
set FontInfo(slant) roman
set FontInfo(underline) 0
set FontInfo(overstrike) 0
set FontInfo(gloss) {}
set FontInfo(fg) "black"
set FontInfo(bg) "gray83"
set FontInfo(help) "?"
set FontInfo(script) {}

set StdFonts {TkDefaultFont\
		  TkTextFont\
		  TkFixedFont\
		  TkMenuFont\
		  TkHeadingFont\
		  TkCaptionFont\
		  TkSmallCaptionFont\
		  TkIconFont\
		  TkTooltipFont}


proc ConditionalSet {varName to} {
     if {![uplevel 1 info exists $varName]} {
       uplevel 1 "set $varName \"$to\""
     }
}
# We require balloon help be in one of the tclIndexs prior to now...
if {![info exists ::auto_index(balloonhelp_for)]} {
  # If not in the auto_index, provide a sub
  proc balloonhelpd_for {args} {}
  proc balloonhelp_for {args} {}
}
    
namespace eval fontsel {
  namespace export CreateFontControlPanel
  namespace export SetUpFonts
  namespace export CreateFonts
  namespace export RecordDefaults
  namespace export SetFontInfoDefaults
  namespace export SaveFontSettings

  variable FontPropertyList \
      [list family size weight slant underline overstrike]
  variable FontInfoList \
      [concat $FontPropertyList [list gloss fg bg help script]]
  variable FontPropertyClass
  variable SelectfontLastindex 0
  variable FontSizeByFamily
  variable haveColorEditor [expr {[isCommand "ColorEditor"] != {}}]

  foreach p $FontPropertyList {
    set FontPropertyClass($p) generic;
  }
  set FontPropertyClass(underline) boolean
  set FontPropertyClass(overstrike) boolean

  #We check the existence of the variable so that this
  #can safely be called AFTER non-default values are set.

  proc SetFontInfoDefaults {} {
    global FontInfo FontInfos FirstFont FontList
    variable FontInfoList
    set FirstFont [lindex $FontList 0]
    foreach ft $::FontList {
      foreach fil $FontInfoList {
	ConditionalSet FontInfos($ft,$fil) $FontInfo($fil)
      }
      if {$FontInfos($ft,gloss) == {} } {set FontInfos($ft,gloss) $ft}
    }
  }


  # Convert a named font to FontInfos, giving it a new name...
  proc FontToFontInfos { font which } {
    global FontInfos
    variable FontPropertyList

    foreach prop  $FontPropertyList {
      set FontInfos($which,$prop) [font actual $font -$prop]
    }
    # Make sure the size is a point size
    FontPixelToPoint $which
  }
  # Convert a FontInfos font to Tcl type 3 font description.
  proc FontToTcl { which } {
    global FontInfos
    set result [list $FontInfos($which,family) \
		    $FontInfos($which,size) \
		    $FontInfos($which,weight) \
		    $FontInfos($which,slant)]
    if {$FontInfos($which,underline)} {
      lappend result "underline"
    }
    if {$FontInfos($which,overstrike)} {
      lappend result "overstrike"
    }
    return $result
  }
  # Font sizes can be either in pixels (<0) or points.
  # To make it easy to work with, here we convert pixels to point
  proc FontPixelToPoint { which } {
    global FontInfos

    if { $FontInfos($which,size) > 0 } {
      return
    }
    # make a copy
    CreateFont $which
    # take a guess...
    set size [expr { - $FontInfos($which,size)}]
    set target [font metrics $which -ascent]
    font configure $which -size $size
    
    while { $target != [set newsize [font metrics $which -ascent]] } { 
      if { $target > $newsize } {
	if { [info exist down] == 1 } {
	  # switch directions.. oops
	  break
	}
	incr size
	set up 1
      } else {
	if { [info exist up] == 1 } {
	  # switch directions.. oops
	  break
	}
	incr size -1
	set down 1
      }
      font configure $which -size $size
    }
    set FontInfos($which,size) $size
    # toss the copy...
    font delete $which
  }
  

  #For a given font assign font-specific properties from generics.
  proc FontSet {which} {
    global FontInfo FontInfos
    variable FontPropertyList
    variable FontInfoList
    foreach prop $FontPropertyList {
      set FontInfos($which,$prop) $FontInfo($prop);
    }
    foreach co {bg fg} {
      if {[info exists fontsel::FontInfo$co] } {
	set FontInfos($which,$co) [set fontsel::FontInfo$co]
      }
    }
  }

  #Assign the proprety values of a specified font to the generics.
  proc InverseFontSet {which} {
    global FontInfo FontInfos
    variable FontPropertyList
    foreach prop $FontPropertyList {
      set FontInfo($prop) $FontInfos($which,$prop);
    }
  }

  #Configure a specified font according to the font-specific properties.
  proc ConfigureFont {which} {
    global FontInfo FontInfos
    variable FontPropertyList
    foreach prop $FontPropertyList {
      font configure $which -$prop $FontInfos($which,$prop)
      # The following makes sure we are using real values by 
      # getting what the system actually is using.
      set FontInfos($which,$prop) [font actual $which -$prop]
    }
  }

  #Record as default values the font-specific values of properties at the
  #time of the call. The recorded values are intended for use by
  #ResetToDefaults 
  proc RecordDefaults {} {
    global FontInfo FontInfos
    global FontList;
    variable FontPropertyList 
    variable FontInfoList

    foreach f $FontList {
      foreach p $FontInfoList {
	set FontInfos($f,$p,Default) $FontInfos($f,$p);
      }
    }
  }

  #Create all of the fonts on the font list and configure them
  #according to the generic values of the properties, which are
  #also assigned at this time to the font-specific variables.
  proc CreateFonts {} {
    global FontList;
    foreach ft $FontList {
      CreateFont $ft
    }   
  }

  proc CreateFont {ft} {
    if {[catch "font create $ft"] == 0} {
      InverseFontSet $ft;
      ConfigureFont $ft;
    }
  }
  # A simple combining function, mostly for export
  proc SetUpFonts {} {
    SetFontInfoDefaults
    CreateFonts
    RecordDefaults
  }
  proc EditColor {color} {
    global ::font_$color
    set w1 ".selectFont.curcan.att.r1c1 configure"
    set w2 ".selectFont.curcan.att.r2c1 configure"
    set c [.selectFont.curcan.att.r1c1 configure -$color]
    set c [lrange $c 4 4]
    #    puts "found color $c"
    if {$c == ""} {set c  grey85}
    ColorEditor font_$color  "$w1 -$color %%; $w2 -$color %%;\
                 set [namespace current]::FontInfo$color %%" $c
    #    puts "setting font_$color to 0"
  }
  
  proc CloneMainFontAsFontControlPanelFont {} {
    variable FontPropertyList
    global FontInfo FontInfos FirstFont
    foreach p $FontPropertyList {
      font configure FontControlPanelFont -$p $FontInfos($FirstFont,$p);
    }
    set FontInfo(fg) $FontInfos($FirstFont,fg)
    set FontInfo(bg) $FontInfos($FirstFont,bg)
  }
  
  proc general {w} {
    global FontInfo FontInfos FirstFont;
    global WhichFontToSet
    global FontList;
    variable FontPropertyList
    set FontTypes [llength $FontList];
    set msg {[_b "For what aspect of the program\ndo\
                         you wish to set the font?"]}
    balloonhelp_for $w $msg
    catch {label $w.title -text [_ "Use for which to set font"] \
	       -anchor c -font FontControlPanelFont}
    catch {frame $w.btns}
    set k 0;
    set PerRow 4;
    set ypad 3
    set xpad 10
    foreach wn [grid slaves $w.btns] {
      grid remove $wn
    }
    foreach ft $FontList {
      set bn $w.btns.f$ft;
      catch {radiobutton $bn -text [_ $FontInfos($ft,gloss)]  \
		 -variable WhichFontToSet -value $ft \
		 -command fontsel::SetFontSelectionDefaults \
		 -font FontControlPanelFont \
		 -indicatoron 0 }
      balloonhelp_for $w.btns.f$ft $FontInfos($ft,help)
      set row [expr 1+ $k/$PerRow]
      set col [expr $k%$PerRow]
      update
      grid $w.btns.f$ft -row $row -column $col \
	  -sticky we -ipadx 3 -padx $xpad -pady $ypad
      incr k
    }
    grid $w.title -column 1 -row 1 -sticky news -ipady 2
    grid $w.btns  -column 1 -row 2 -sticky news -ipady 2
    grid columnconfigure $w 1 -weight 1

  }
  proc TraceOn {} {
    trace add variable ::FontInfo write fontsel::FontShow
  }
  proc TraceOff {} {
    return [trace remove variable ::FontInfo write fontsel::FontShow]
  }
  ############################################################################
  # This is the main procedure of this package.
  # It creates the font control panel.
  # args is the name of the font to set up (used to set WhichFontToSet)
  # and it should already be in FontList
  # if not supplied, WhichFontToSet is set to the first one in the FontList
  # if the window already exists, the list of fonts is redisplayed (assuming
  # some may have been added or deleted).

  proc CreateFontControlPanel {args} {
    global FontInfo FontInfos FirstFont;
    global WhichFontToSet
    global FontList;
    variable FontPropertyList
    variable haveColorEditor
    if {"FontControlPanelFont" ni [font names]} {
      font create FontControlPanelFont
    }
    set General 1
    set exwid 10
    set w .selectFont
    # always start fresh...
    while {[winfo exists $w]} {Exit $w}
    toplevel $w
    wm iconify $w
    wm title $w [_ "Font Selection"]
    wm protocol $w WM_DELETE_WINDOW [namespace code "Exit $w"]
    label $w.which -relief ridge -border 3\
	-text [_ "Please wait while the
 available fonts are examined."]\
	-width 30\
	-height 4
    grid $w.which -column 1 -row 1 -sticky news -padx 8 -pady 6
    #wm deiconify $w
    
    #The idea is that in general we want to use the main
    #font here, but we keep them separate so that we
    #can wait before switching the control panel to
    #the new main font configuration so that
    #the user isn't confronted with an unusable
    #control panel if he or she sets the mainfont to something
    #crazy.
    SetUpFonts
    CloneMainFontAsFontControlPanelFont;

    if {[llength $args] > 0} {
      set ::WhichFontToSet [lindex $args 0];
    } 
    set FontTypes [llength $FontList];
    if {$FontTypes == 1} {
      set ::WhichFontToSet [lindex $FontList 0];
      set General 0;
    }
    # Make sure WhichFontToSet is in the FontList
    if {[lsearch -exact $FontList $WhichFontToSet] == -1} {
      set WhichFontToSet [lindex $FontList 0]
    }
    #     puts "Before General $General"

    if {$General} {
      general $w.which
    }

    frame $w.mid 
    frame $w.mid.opts  -relief ridge -border 3
    frame $w.mid.size  -relief ridge -border 3 
    # frame $w.mid.fixed  -relief ridge -border 3
    frame $w.mid.std -relief ridge -border 3
    # label $w.mid.fixed.lab -text [_ "Fixed"] -relief ridge \
	-justify center -font FontControlPanelFont
    frame $w.mid.families  -relief ridge -border 3
    listbox $w.mid.families.lbx -height 1 -exportselection 0 \
	-yscrollcommand "fontsel::YscrollFixed $w.mid.families.sbar set"\
	-selectmode single -activestyle none \
	-font FontControlPanelFont -width 0

    label $w.mid.families.labx -text [_ "Fixed/Prop"] \
	-relief ridge \
	-justify center -font FontControlPanelFont
    label $w.mid.families.lab -text [_ "Family"] \
	-relief ridge \
	-justify center -font FontControlPanelFont
    listbox $w.mid.families.lb -height 1 -exportselection 0 \
	-yscrollcommand "fontsel::YscrollFixed $w.mid.families.sbar set"\
	-selectmode single  -activestyle none \
	-font FontControlPanelFont -width 0
    scrollbar $w.mid.families.sbar -orient vertical \
	-command "fontsel::ScrollFixed"
    bind $w.mid.families.sbar <<B3>> \
	"ScrollbarMoveBigIncrement $w.mid.families.sbar 0.20 %x %y"

    bind $w.mid.families.lb <<B3>> "fontsel::test  %W %y"
    
    grid $w.mid.families.labx -column 1     -row 1 -sticky new
    grid $w.mid.families.lab  -column 2     -row 1 -sticky new
    grid $w.mid.families.lbx  -column 1     -row 2 -sticky news
    grid $w.mid.families.lb   -column 2     -row 2 -sticky news
    grid $w.mid.families.sbar -column 3     -row 2 -sticky news
    grid rowconfigure $w.mid.families 2 -weight 2
    
    label $w.mid.opts.lab -text [_ "Attributes"] -relief ridge \
	-justify center -font FontControlPanelFont
    #Font size selection set up here
    label $w.mid.size.lab -text [_ "Size"]  -relief ridge\
	-font FontControlPanelFont
    listbox $w.mid.size.lb -yscrollcommand "$w.mid.size.sbar set" \
	-listvariable FontSize -selectmode single  -width 0 \
	-font FontControlPanelFont -height 1 -exportselection 0
    scrollbar $w.mid.size.sbar -orient vertical \
	-command "$w.mid.size.lb yview"
    label $w.mid.std.lab -text [_ "Standard Tcl Fonts"]  -relief ridge\
	-font FontControlPanelFont
    listbox $w.mid.std.lb -yscrollcommand "$w.mid.std.sbar set" \
	-listvariable StdFonts -selectmode single  -width 0 \
	-font FontControlPanelFont -height 1 -exportselection 0
    scrollbar $w.mid.std.sbar -orient vertical \
	-command "$w.mid.std.lb yview"
    bind $w.mid.size.lb <ButtonRelease-1> \
	{set index [.selectFont.mid.size.lb curselection]; \
             if { $index == "" } {set index 0}; \
	     fontsel::ClearStdFontHighlight; \
             set FontInfo(size) \
	     [lrange [split $FontSize \n] $index $index]}

    label $w.mid.opts.weightl -text [::msgcat::mc "Bold:"] \
	-font FontControlPanelFont	    
    checkbutton $w.mid.opts.weight -variable FontInfo(weight) \
	-onvalue bold -offvalue normal  -font FontControlPanelFont\
	-command  fontsel::ClearStdFontHighlight

    label $w.mid.opts.slantl -text [::msgcat::mc "Italic:"] \
	-font FontControlPanelFont
    checkbutton $w.mid.opts.slant -variable FontInfo(slant) \
	-onvalue italic -offvalue roman -font FontControlPanelFont\
	-command  fontsel::ClearStdFontHighlight

    label $w.mid.opts.ulinel -text [::msgcat::mc "Underline:"] \
	-font FontControlPanelFont
    checkbutton $w.mid.opts.uline -variable FontInfo(underline) \
	-onvalue 1 -offvalue 0  -font FontControlPanelFont\
	-command  fontsel::ClearStdFontHighlight

    label $w.mid.opts.strkovl -text [::msgcat::mc "Overstrike:"] \
	-font FontControlPanelFont
    checkbutton $w.mid.opts.strkov -variable FontInfo(overstrike) \
	-onvalue 1 -offvalue 0  -font FontControlPanelFont\
	-command  fontsel::ClearStdFontHighlight

    grid $w.mid.opts.lab   -row 0 -column 0 -columnspan 5 -sticky ew

    grid $w.mid.opts.weightl -row 1 -column 0 -sticky w
    grid $w.mid.opts.weight  -row 1 -column 1 -sticky w
    grid $w.mid.opts.slantl  -row 2 -column 0 -sticky w
    grid $w.mid.opts.slant   -row 2 -column 1 -sticky w
    grid $w.mid.opts.ulinel  -row 3 -column 0 -sticky w
    grid $w.mid.opts.uline   -row 3 -column 1 -sticky w
    grid $w.mid.opts.strkovl -row 4 -column 0 -sticky w
    grid $w.mid.opts.strkov  -row 4 -column 1 -sticky w

    grid $w.mid.size.lab  -columnspan 2 -row 1 -sticky new 
    grid $w.mid.size.lb   -column 1     -row 2 -sticky news
    grid $w.mid.size.sbar -column 2     -row 2 -sticky news
    grid rowconfigure $w.mid.size 2 -weight 2

    grid $w.mid.std.lab  -columnspan 2 -row 1 -sticky new
    grid $w.mid.std.lb   -column 1     -row 2 -sticky news
    grid $w.mid.std.sbar -column 2     -row 2 -sticky news   
    grid rowconfigure $w.mid.std 2 -weight 2

    grid $w.mid.families -column 1 -row 1 -sticky news
    grid $w.mid.opts     -column 2 -row 1 -sticky news
    grid $w.mid.size     -column 3 -row 1 -sticky news
    grid $w.mid.std      -column 4 -row 1 -sticky news
    grid rowconfigure $w.mid all -weight 2
    
    #set families [lsort -unique  [font families]]
    set newFonts {}
    foreach font [font families] {
      if {[string match -nocase *emoji* $font]} {continue}
      # Houston "We have a problem." Some ware along the line the
      # font metrics code lost the ability to determin if a font is
      # fixed. It this changes this code can be reverted...
      if {0} {
        set Fixed_Prop [expr {[font metrics [list -family $font] -fixed] == 0 ? \
				"Proportional" : "Fixed"}]
      } else {
        set Fixed_Prop [expr {[font measure [list -family $font] "l"] !=\
                                  [font measure [list -family $font] "M"] ? \
                                  "Proportional" : "Fixed"}]
      }
      lappend newFonts [list $Fixed_Prop $font]
    }
    foreach font [lsort -unique $newFonts] {
      $w.mid.families.lbx insert end [lindex $font 0]
      $w.mid.families.lb  insert end [lindex $font 1]
    }

    # Slow down the wheel scroll
    set scrollUnit 2
    bind $w.mid.families.lbx <4> "%W yview scroll -$scrollUnit units;break"
    bind $w.mid.families.lbx <5> "%W yview scroll  $scrollUnit units;break"
    bind $w.mid.families.lb  <4> "%W yview scroll -$scrollUnit units;break"
    bind $w.mid.families.lb  <5> "%W yview scroll  $scrollUnit units;break"
    
    bind $w.mid.families.lb <ButtonPress-1> \
	{fontsel::SelectFontFamily %W %y }
    # bind $w.mid.families.lb <Activate> \
    #     {fontsel::SelectFontFamily %W %y }
    bind $w.mid.families.lbx <ButtonPress-1> \
	{fontsel::SelectFontFamilyx %W %y }
    bind $w.mid.std.lb <ButtonPress-1> {fontsel::StdFontSelection %W %y}

    frame $w.cntls -relief ridge -border 3
    button $w.cntls.sav -text [_ "Apply"]  -command fontsel::FontSave \
	-font FontControlPanelFont
    button $w.cntls.res -text [_ "Cancel"] -command  fontsel::ResetToDefaults \
	-font FontControlPanelFont
    button $w.cntls.can -text [_ "Exit Font Select"] -command "fontsel::Exit $w" \
	-font FontControlPanelFont
    button $w.cntls.cpanel -text [_ "Here Too?"] \
	-command fontsel::CloneMainFontAsFontControlPanelFont \
	-font FontControlPanelFont
    
    grid $w.cntls.cpanel -column 1 -row 1 -sticky news -padx 2 -pady 2
    grid $w.cntls.can    -column 2 -row 1 -sticky news  -padx 2 -pady 2
    grid $w.cntls.res    -column 3 -row 1 -sticky news  -padx 2 -pady 2
    grid $w.cntls.sav    -column 4 -row 1 -sticky news -padx 2 -pady 2
    grid columnconfigure $w.cntls all -weight 2

    balloonhelp_for $w.cntls.can \
	{[_b "Press this button to dismiss the popup."]}
    balloonhelp_for $w.cntls.res \
	{[_b "Press this button to reset the font to its defaults."]}
    balloonhelp_for $w.cntls.sav {[_b "Press this button to make the\
                                  changes\nyou have made take effect."]}
    balloonhelp_for $w.cntls.cpanel {[_b "Press this button to set the\
                               fonts\nin this control panel to the %s font."\
					  [_b $::FontInfos($::FirstFont,gloss)]]}

    frame $w.curcan -relief ridge -border 1
    set ATT [frame $w.curcan.att]
    set Row 0
    foreach r {Header Current Candidate} {
      set Column 2
      foreach p $FontPropertyList {
	set v $w.curcan.att.r${Row}c${Column};
	label $v  -font FontControlPanelFont
	incr Column;
      } 
      incr Row;
    }

    #     puts "Creating example fonts $WhichFontToSet"
    font create CurrentFontExampleFont \
	-family $FontInfos($::WhichFontToSet,family) \
	-size $FontInfos($::WhichFontToSet,size) \
	-weight $FontInfos($::WhichFontToSet,weight) \
	-slant $FontInfos($::WhichFontToSet,slant) \
	-underline $FontInfos($::WhichFontToSet,underline) \
	-overstrike $FontInfos($::WhichFontToSet,overstrike);

    font create CandidateFontExampleFont \
	-family $FontInfos($::WhichFontToSet,family) \
	-size $FontInfos($::WhichFontToSet,size) \
	-weight $FontInfos($::WhichFontToSet,weight) \
	-slant $FontInfos($::WhichFontToSet,slant) \
	-underline $FontInfos($::WhichFontToSet,underline) \
	-overstrike $FontInfos($::WhichFontToSet,overstrike);

    #	label $w.curcan.att.r0c0 -font FontControlPanelFont
    #	label $w.curcan.att.r0c1 -font FontControlPanelFont

    radiobutton $w.curcan.att.r0c0  \
	-text "FG Color" \
	-variable dum \
	-value 1 \
	-indicatoron 0  \
	-font FontControlPanelFont \
	-command "set dum 0;fontsel::EditColor fg" 
    set mes "click here to open the color editor to select an example"
    balloonhelp_for $w.curcan.att.r0c0 [_ "$mes Forground color"]
    radiobutton $w.curcan.att.r0c1\
	-variable dum \
	-value 1 \
	-text "BG Color" \
	-indicatoron 0   \
	-font FontControlPanelFont \
	-command "set dum 0;fontsel::EditColor bg" 
    balloonhelp_for $w.curcan.att.r0c1 {[_b "$mes Background color"]}
    label $w.curcan.att.r1c0  -text [_ "Current"] \
	-font FontControlPanelFont
    if {"live" in $args} {
      set ::FontLive 1
      entry $w.curcan.att.r1c1 -font FontControlPanelFont \
	  -relief flat -width $exwid\
	  -fg $FontInfo(fg)\
	  -bg $FontInfo(bg)
      entry $w.curcan.att.r2c1 -font FontControlPanelFont \
	  -relief flat  -width $exwid\
	  -fg $FontInfo(fg)\
	  -bg $FontInfo(bg)
      $w.curcan.att.r2c1 insert 0 [_ "live.."]
    } else {
      entry $w.curcan.att.r1c1 -font CurrentFontExampleFont \
	  -relief flat -width $exwid\
	  -fg $FontInfo(fg)\
	  -bg $FontInfo(bg)
      entry $w.curcan.att.r2c1 -font CandidateFontExampleFont \
	  -relief flat  -width $exwid\
	  -fg $FontInfo(fg)\
	  -bg $FontInfo(bg)
      $w.curcan.att.r2c1 insert 0 [_ "example 1 9"]
    }
    $w.curcan.att.r1c1 insert 0 [_ "example 1 9"]
    label $w.curcan.att.r2c0  -text [_ "Candidate"] \
	-font FontControlPanelFont
    #This is for use in conjunction with my character insertion library.
    #It arranges for the various character insertion widgets to insert
    #characters into the focused window.
    if {[llength [info commands BindInsertionTarget]]} {
      BindInsertionTarget $w.curcan.att.r1c1;
      BindInsertionTarget $w.curcan.att.r2c1;
    }
    #Now grid them all
    set xp 5
    set yp 3
    set CLimit [expr [llength $FontPropertyList] + 2];
    for {set r 0} {$r < 3} {incr r} {
      for {set c 0} {$c < $CLimit} {incr c} {
	set v $w.curcan.att.r${r}c${c};
	grid $v -row $r -column $c -sticky w -padx $xp -pady $yp
      } 
    }
    if {!$haveColorEditor} {
      grid forget $w.curcan.att.r0c0 $w.curcan.att.r0c1
    }
    set xp 3
    set yp 1
    if {!$General} {
      $w.curcan.att.r1c0 configure -text \
	  [string totitle [_ $FontInfos($::WhichFontToSet,gloss)]]
    }

    grid $w.curcan.att -sticky news  -padx 3 -pady 5

    #Put it all together
    grid $w.curcan -column 1 -row 2 -sticky news -padx 8 -pady 6
    grid $w.mid    -column 1 -row 3 -sticky news -padx 8 -pady 1
    grid $w.cntls  -column 1 -row 4 -sticky news -padx 8 -pady {2 4}
    grid rowconfigure $w all  -weight 0
    grid rowconfigure $w 3    -weight 2
    
    
    TraceOn
    #    wm protocol $w WM_DELETE_WINDOW "fontsel::Exit $w"
    if {$General} {
      #  Default to requested by WhichFontToSet
      after 100 ".selectFont.which.btns.f$WhichFontToSet invok"
    }
    # in some systems we seem to need the withdraw to get the deiconify to work
    wm withdraw   $w
    wm deiconify  $w

    return $w;
  }
  # exit, clean up and...
  proc Exit { w } {
    global FontInfo FontSelDone
    wm withdraw $w
    catch {font delete CurrentFontExampleFont}
    catch {font delete CandidateFontExampleFont}
    set FontSelDone [TraceOff]
    
    LeaveAll $w 
    destroy $w
    #    balloonhelp_cancel
    # clean up any remainging color editor windows...
    catch {destroy .font_bg .font_fg}
    #    puts "exit fontgui"
  }
  # messy but it puts down any left over tool tips
  
  proc LeaveAll {w} {
    event generate $w <Leave>
    foreach child [winfo children $w] {
      LeaveAll $child
    }
  }
  # These functions tie the two listboxes into one... 
  proc ScrollFixed { a {b ""} {c ""} } {
    set w .selectFont
    if {$c == ""} {
      $w.mid.families.lbx yview $a $b 
      $w.mid.families.lb yview $a $b
    } else {
      $w.mid.families.lbx yview $a $b $c
      $w.mid.families.lb yview $a $b $c
    }
    return
  }
  proc YscrollFixed { w cmd first last } {
    $w $cmd $first $last
    ScrollFixed moveto $first
  }
  #This resets the properties of the font specified by WhichFontToSet
  #to their default values, where "default" means whatever values
  #are stored in FontInfos(<font>,<property>,Default). The intention
  #is that these values will have been set by RecordDefaults at
  #a suitable point. A suitable point might be program startup or it
  #might be after init files have been read.
  #After resetting the attributes for the current font to their
  #default values, it configures the fonts for both the current and candidate
  #examples in the control panel to match.
  proc ResetToDefaults {} {
    global FontInfo FontInfos
    global WhichFontToSet
    variable FontPropertyList
    variable FontInfoList

    foreach prop $FontInfoList {
      set FontInfos($::WhichFontToSet,$prop) \
	  $FontInfos($::WhichFontToSet,$prop,Default);
      set FontInfo($prop) $FontInfos($::WhichFontToSet,$prop,Default);
    }
    # Not sure here.  Could we have a list?
    ConfigureFont $::WhichFontToSet;
    ConfigureCurrentExampleFont;
    ConfigureCandidateExampleFont;
    DescribeBothFonts;
  }

  #This is the procedure called from the control panel when the user decides
  #to apply and save the values set on the control panel. It sets the 
  #font-specific attributes from the generic ones, configures the 
  #target font as well as the current example font, and updates 
  #the description of the current font in the control panel.
  #The caller of the whole pannel should "trace" writes to FontApply
  #and use the font when it is set.
  # Or, better, the caller can supply a script in FontInfos(<font>,script)
  # to which we will append the <font name> and <tcl font description>

  proc FontSave {} {
    global FontInfo FontInfos FontApply
    set f $::WhichFontToSet;
    FontSet $f;
    ConfigureFont $f
    set FontApply $f
    ConfigureCurrentExampleFont;
    DescribeBothFonts;
    if {$FontInfos($f,script) != {}} {
      TraceOff
      eval {{*}$FontInfos($f,script) $f [FontToTcl $f]}
      TraceOn
    }
  } 

  #This procedure configures the font used to display the candidate example
  #in the control panel. It is intended to be called whenever a property
  #is changed in the control panel or when the target font is changed.
  proc ConfigureCandidateExampleFont {} {
    global FontInfo FontInfos FontSize
    global WhichFontToSet
    variable FontPropertyList 
    variable FontSizeByFamily
    foreach prop $FontPropertyList {
      font configure CandidateFontExampleFont -$prop $FontInfo($prop)
    }
    # Use actual values...
    # see if we need to build a size list
    # The problem is that we have no way of directly getting the
    # supported font sizes.  We can get the default (usually 12)
    # by setting size 0 and then checking "font actual" to see what
    # it is.  Beyond that, "font actual" seems to just return what
    # was set, regardless of if it is a possible size or not.
    # "font measure" on the other hand does seem to return 
    # useful info... well, most of the time...
    # here we go..
    if { [ info exists FontSizeByFamily($FontInfo(family)) ]  } {
      set FontSize $FontSizeByFamily($FontInfo(family))
    } else {
      font configure CandidateFontExampleFont -size 0
      set defaultsize [font actual CandidateFontExampleFont -size]
      # if the size changes with each increment, assume the prior
      # exists.  If not, then we have a void...
      set measured [font measure CandidateFontExampleFont "W"]
      set FontSize $defaultsize\n
      set updn -1
      set void 0
      set measurel $measured
      foreach inc { -1 1 } {
	set size $defaultsize
	set limit 0
	set maxsize [expr {[info exists ::FontLive] ? 300 : 55}]
	while { $size > 5 && $size < $maxsize } {
	  if { [incr limit] > ($maxsize * 2) } {
	    return
	  }
	  font configure CandidateFontExampleFont -size [incr size $inc]
	  set measure [font measure CandidateFontExampleFont "W"]
	  if { $measure == $measurel } {
	    set void $size
	    continue
	  } else {
	    set measurel $measure
	    if { $void } {
	      # guess at the real next size...
	      set newsize \
		  [expr round(( $measure.0 / $measured) * $defaultsize)]
	      #puts "$void $size $newsize $measure $measured $defaultsize"
	      set void 0
	      set count 0
	      # inner loop ---------------------------------
	      while { 1 } {
		if { [incr count] > 10 } {
		  break
	      	}
		font configure CandidateFontExampleFont -size $newsize
	    	set rmeasure [font measure CandidateFontExampleFont "W"]
		if { $rmeasure == $measure } {
		  append FontSize $newsize\n
		  set size $newsize
		  break
		} else {
		  if { $newsize > $size } {
		    if { $inc == -1 } {
		      break
		    }
		  }
		  if { $newsize < $size } {
		    if { $inc == 1 } {
		      break
		    }
		  }

		  if { $rmeasure > $measure } {
		    incr newsize -1
		  } else {
		    incr newsize
		  }
		  continue
		}
	      }
	      continue
	    }
	    # no void... nosize changed with no gap.  
	    append FontSize $size\n
	  }
	}
      }
      set FontSize [join [lsort -unique -integer   $FontSize] \n]
      font configure CandidateFontExampleFont -size $FontInfo(size)
      set FontSizeByFamily($FontInfo(family)) $FontSize
    }
    # Test if the font supports overstrike and underline.  If not
    # disable them
    set w .selectFont
    set os [font actual CandidateFontExampleFont -overstrike]
    font configure CandidateFontExampleFont -overstrike 1
    if { [font actual CandidateFontExampleFont -overstrike] == 0 } {
      $w.mid.opts.strkov configure -state disabled -background red
      set os 0
    } else { 
      $w.mid.opts.strkov configure -state normal
    }
    set ul [font actual CandidateFontExampleFont -underline]
    font configure CandidateFontExampleFont -underline 1
    if { [font actual CandidateFontExampleFont -underline] == 0 } {
      $w.mid.opts.uline configure -state disabled -background red
      set ul 0
    } else { 
      $w.mid.opts.uline configure -state normal
    }
    set FontInfo(overstrike) $os
    set FontInfo(underline) $ul
    font configure CandidateFontExampleFont -underline $ul -overstrike $os
    
    set testlist [split $FontSize \n]
    if { [llength $testlist] == 1 } {
      $w.mid.size.lb configure -state disabled
    } else {
      $w.mid.size.lb configure -state normal
    }
    
    set last [lrange $testlist 0 0]
    set index -1
    foreach entry  $testlist {
      incr index
      if { $entry < $FontInfo(size)} {
	set last $entry
	continue
      } else {
	if { $entry == $FontInfo(size) } {
	  set  FontInfo(size) $entry
	  # show the selected font size
	  if { [set cur [$w.mid.size.lb curselection]] != "" } {
	    $w.mid.size.lb selection clear $cur
	  }
	  $w.mid.size.lb see $index
	  $w.mid.size.lb selection set $index
	  return
	} else {
	  break
	}
      }
    }
    set FontInfo(size) $last
  }	  
  
  #This procedure configures the font used to display the current example
  #in the control panel. It is intended to be called when the user
  #applies new values or when the target font is changed.
  proc ConfigureCurrentExampleFont {} {
    global FontInfo FontInfos
    global WhichFontToSet
    variable FontPropertyList

    foreach prop $FontPropertyList {
      font configure CurrentFontExampleFont \
	  -$prop $FontInfos($::WhichFontToSet,$prop)
    }
  }

  #This procedure configures the candidate example font and updates the
  #description of the candidate font in the control panel. It is intended
  #to be called whenever a proprty of the candidate font is changed.
  proc FontShow {args} {
    global FontInfo
    TraceOff
    ConfigureCandidateExampleFont;
    DescribeBothFonts;
    if {[info exists ::FontLive]} {
      FontSet $::WhichFontToSet
      ConfigureFont $::WhichFontToSet
    }
    TraceOn
  }

  #This procedure generates the descriptions of the current and candidate
  #fonts that are shown in the control panel.
  proc DescribeBothFonts {} {
    global FontInfo FontInfos
    global WhichFontToSet;
    variable FontPropertyList
    set f $::WhichFontToSet;
    set c 2;

    foreach prop $FontPropertyList {
      .selectFont.curcan.att.r0c$c configure \
	  -text  [string totitle [_ $prop]] 
      set value $FontInfos($f,$prop)
      if {$value == 1} {set value [_ "Yes"]} else {
	if {$value == 0} {set value [_ "No"]}}
      .selectFont.curcan.att.r1c$c configure -text $value;
      set value $FontInfo($prop)
      if {$value == 1} {set value [_ "Yes"]} else {
	if {$value == 0} {set value [_ "No"]}}
      .selectFont.curcan.att.r2c$c configure -text $value; 
      incr c;
    }
  }

  #This is to be called when we change font targets.
  #It resets the control panel to show the current
  #configuration for the newly targeted font.
  proc SetFontSelectionDefaults {} {
    global FontInfo FontInfos
    global WhichFontToSet;
    variable FontPropertyList
    variable FontInfoList
    
    TraceOff
    foreach prop $FontInfoList {
      set FontInfo($prop) $FontInfos($WhichFontToSet,$prop);
    }
    # set FontInfo(sizes) $FontInfos($WhichFontToSet,$prop)
    HighLightFamily [set FontInfo(family) \
			 $FontInfos($WhichFontToSet,family)]
    .selectFont.curcan.att.r1c1 configure \
	-fg $FontInfo(fg) \
	-bg $FontInfo(bg)
    .selectFont.curcan.att.r2c1 configure \
	-fg $FontInfo(fg) \
	-bg $FontInfo(bg)
    ConfigureCandidateExampleFont
    ConfigureCurrentExampleFont;
    DescribeBothFonts;
    TraceOn
  }

  proc HighLightFamily { family} {
    set FontChoices [.selectFont.mid.families.lb size];
    set k 0
    
    while {$k <= $FontChoices} {
      set Family [string tolower [.selectFont.mid.families.lb get $k]];
      if {[string equal $Family [string tolower $family]]} {
	.selectFont.mid.families.lb selection clear 0 end;
	.selectFont.mid.families.lbx selection clear 0 end;
	.selectFont.mid.families.lbx see $k
	.selectFont.mid.families.lb selection set $k $k;
	.selectFont.mid.families.lbx selection set $k $k;
	.selectFont.mid.families.lb activate $k;
	break
      }
      incr k;
    }
  }
  # make this routine return with out doing anything if not 
  # debugging...
  proc putss { s } {
     return
    fconfigure stdout -buffering none
    puts stdout "FontControl: $s"
    flush stdout
  }

  proc test { w y} {
    SelectFontFamily $w $y
  } 
  proc SelectFontFamilyx { w y } {
    set wr .selectFont
    SelectFontFamily $wr.mid.families.lb $y
  }
  
  #This is the callback that extracts a new font family
  #setting from the control panel.
  proc SelectFontFamily {w y } {
    set index [$w nearest $y]
    global FontInfo FontInfos
    set wr .selectFont
    variable SelectfontLastindex

    ClearStdFontHighlight
    if {$index != ""} {
      HighLightFamily [set FontInfo(family) [$w get $index]]
    }
  }
  
  # a standard font is selected.  Copy and convert it...
  proc StdFontSelection { w y } {
    global FontInfo FontInfos
    set index [$w nearest $y]
    #       catch {font create testfont}
    FontToFontInfos [$w get $index] testfont
    InverseFontSet testfont
    #        font delete testfont
    HighLightFamily $FontInfo(family)

  }
  proc ClearStdFontHighlight { } {
    .selectFont.mid.std.lb selection clear 0 end
  }
  #This is the callback that extracts a new font size
  #from the control panel.
  proc SelectFontSize {w} {
    global WhichFontToSet
    global FontInfo FontInfos

    ClearStdFontHighlight
    set size [$w get]
    if {[catch {expr round($size)} size] == 0} {
      if { ($size > 0) && ($size <= 60) } {
	set FontInfo(size) $size
	return ;
      }
    }
    $w delete 0 end
    $w insert 0 $FontInfos($WhichFontToSet,size)
  }

  #This is presently a stub.
  #It is intended to be called on an event, probably <B3>,
  #in the font family listbox in the control panel.
  #Its purpose is to provide the user with information about
  #the particular font. 
  proc ProvideFontDescription {w y} {
    variable FontDescriptions

    set index [$w nearest $y]
    if {$index != ""} {
      FontDescriptions([$w get $index])
    }
  }

  #Create a command for setting each combination of font and property.
  proc DefineFontSettingProcs {} {
    variable FontPropertyList
    variable FontPropertyClass
    global FontList;
    global FontProcList;
    foreach ft $FontList {
      foreach prop $fontsel::FontPropertyList {
	if {[string equal $FontPropertyClass($prop) boolean]} {
	  set ProcName  [format "::fontsel::Set%s%sP" $ft \
			     [string totitle $prop]];
	  lappend FontProcList $ProcName;
	  set cmd \
	      [list "proc"  $ProcName  "\{v\}" \
		   "set ::FontInfos($ft,$prop) \[SlaveBoolean \$v\];\nConfigureFont $ft;"]
	} else {
	  set ProcName  [format "::fontsel::Set%s%s" $ft \
			     [string totitle $prop]];
	  lappend FontProcList $ProcName;
	  set cmd [list "proc" $ProcName "\{v\}" \
		       "set ::FontInfos($ft,$prop) \$v;\nConfigureFont $ft;"]
	}
	eval $cmd;
      }
    }
  }

  #Create aliases in the named daughter interpreter for the 
  #font setting commands
  proc AliasFontSettings {interp} {
    variable FontPropertyList
    variable FontPropertyClass
    global FontList;
    
    foreach ft $FontList {
      foreach prop $FontPropertyList {
	set Tprop [string totitle $prop]
	set Tprop2 $Tprop;
	if {[string equal $FontPropertyClass($prop) boolean]} {
	  set Tprop ${Tprop}P
	}
	eval [split [format "%s alias %s%s ::fontsel::Set%s%s" \
			 $interp $ft $Tprop $ft $Tprop2]]
      }
    }
  }

  # Returns a list of init file commands representing the current 
  # font settings. This list may be written to a file to be sourced
  # at some later time to set up the same font settings as now.
  # May be written as 'puts fid "[join [SaveFontSettings] \n]"'
  # We leave it as a list for possible other uses...
  proc SaveFontSettings {} {
    variable FontPropertyList
    variable FontPropertyClass
    global FontInfo FontInfos
    global FontList;
    
    set cl [list]
    foreach ft $FontList {
      foreach prop $FontPropertyList {
	#set Tprop [string totitle $prop]
	if {[string equal $FontPropertyClass($prop) boolean]} {
	  #    set Tprop ${Tprop}P
	}
	lappend cl \
	    [format "set FontInfos(%s,%s) %s" \
		 $ft $prop [list $FontInfos($ft,$prop)]]
      }
    }
    lappend cl "fontsel::SetUpFonts"
    return $cl
  }
}

# End of namespace fontsel

# To use the system, the programmer must, at minimum, 
# define the font list, e.g.:
#####Stuff after this point is needed for the above code to run properly
#but has nothing particular to do with font selection.

proc ScaleMoveBigIncrement {w k x y} {
  set part [$w identify $x $y]
  set inc 0;
  switch -exact -- $part {
    trough1 {
      set dir -1;
    }
    trough2 {
      set dir  1;
    }
    default {
      return ;
    }
  }
  set Resolution [$w cget -resolution]
  set CurrentValue [$w get]
  set Delta [expr $dir * $k * $Resolution]
  $w set [expr $CurrentValue + $Delta]
}

proc ScrollbarMoveBigIncrement {w f x y} {
  set part [$w identify $x $y]
  switch -exact -- $part {
    trough1 {
      set dir -1;
    }
    arrow1 {
      set dir -1;
    }
    trough2 {
      set dir  1;
    }
    arrow2 {
      set dir  1;
    }
    default {
      return ;
    }
  }
  set CurrentFraction [lindex [$w get] 0]
  set NewFraction [expr $CurrentFraction + ($dir * $f)]
  eval [concat [$w cget -command] moveto $NewFraction]
}

#Figure out what system we are running on
if {[string equal $::tcl_platform(platform) windows]} {
  set System MSWindows;
} elseif {[string equal $::tcl_platform(platform) unix]} {
  if {[string equal $::tcl_platform(os) Darwin]} {
    set System MacOSX;
  } else {
    set System Unix;
  }
}

switch $System {
  Unix {
    event add <<B3>> <ButtonPress-3>
    event add <<B3Release>> <ButtonRelease-3>
  }
  MacOSX {
    event add <<B3>> <Control-ButtonPress-1>
    event add <<B3Release>> <Control-ButtonRelease-1>
  }
  MSWindows {
    event add <<B3>> <ButtonPress-3>
    event add <<B3Release>> <ButtonRelease-3>
    set NonBinPath [file dirname [info script]];
    set ::env(CYGWIN) "";
    set InitFile "SndBiteInit";
    set JournalFile "SndBiteLog";
  }
}

if {[isCommand "_"] == {}} {
  proc _ {s args} {return [format $s {*}$args]}
}
if {[isCommand "_b"] == {}} {
  proc _b {s args} {return [format $s {*}$args]}
}
