### Copyright (C) 1995, 1996, 1997 Jeppe Buk (buk@imada.ou.dk)
### This program is free software; you can redistribute it and/or modify
### it under the terms of the GNU General Public License as published by
### the Free Software Foundation; either version 2 of the License, or
### (at your option) any later version.
###
### 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
### GNU General Public License for more details.
###
### You should have received a copy of the GNU General Public License
### along with this program; if not, write to the Free Software
### Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

# Extended tk_optionMenu
#  -- Sun Jan 12 20:41:22 1997 -- Jeppe Buk
#
# w -		The name to use for the menubutton.
# varName -	Global variable to hold the currently selected value.
# maxHeight -	Maximum entries in one column
# firstValue -	First of legal values for option (must be >= 1).
# args -	Any number of additional values.

# Small helper
proc buildMenuName { no } {
  set name menu0
  for {set i 1} {$i <= $no} {incr i} {
    append name ".menu$i"
  }
  return $name
}

# The function
proc ext_optionMenu {w varName maxHeight firstValue args} {
  upvar #0 $varName var

  if ![info exists var] {
    set var $firstValue
  }
  menubutton $w -textvariable $varName -indicatoron 1 -menu $w.menu0 \
      -relief raised -bd 2 -highlightthickness 2 -anchor c

  # The (sub) menus
  set noMenus [expr ([llength $args]+1) / $maxHeight + 1]
  for {set j 0} {$j < $noMenus} {incr j} {
    menu $w.[buildMenuName $j] -tearoff 0
  }
  $w.menu0 add command -label $firstValue \
      -command [list set $varName $firstValue]

  set curNo 1
  foreach i $args {
    set prevMenu [expr $curNo / $maxHeight - 1]
    set curMenu [expr $curNo / $maxHeight]
    if {$curNo % $maxHeight == 0} {
      $w.[buildMenuName $prevMenu] add separator
      $w.[buildMenuName $prevMenu] add cascade -label "More..." \
	  -menu $w.[buildMenuName $curMenu]
    }
    $w.[buildMenuName $curMenu] add command -label $i \
	-command [list set $varName $i]
    incr curNo
  }
  return $w.menu
}

# Use this for -setvalue
proc buttonSetText {widget font} {
  $widget configure -text $font
  set err [catch {$widget configure -font $font}]
  if {$err} {
    $widget configure -font fixed
    $widget configure -text "$font (not found)"
  }
}

proc FontWidget {defaultFont mustExist} {
  global fontInfo
  if {![info exists fontInfo]} {
    error "No fontInfo set"
  }
  global fontChoice
  global currFont
  set currFont $defaultFont
  global __result
  set __result $defaultFont
  global __mustExist
  set __mustExist $mustExist
  global __fontExists
  set __fontExists 0
  global __fontFullSample
  set __fontFullSample 0

  global __fontCharset
  for {set i 32} {$i < 255} {incr i} {
    eval append __fontCharset "\\x[itoh $i] "
  }

  toplevel .font
  pushGrab local .font

  #####################
  ## Attributes
  ##
  frame .font.attr
  pack .font.attr -anchor nw
  label .font.attr.label -text "Font Attributes:"
  pack .font.attr.label -anchor nw

  frame .font.attr.line1
  pack .font.attr.line1 -anchor nw
  foreach var {fndry fmly wght slant swdth adstyl pxlsz} {
    frame .font.attr.line1.frame_$var
    pack .font.attr.line1.frame_$var -side left
    label .font.attr.line1.frame_$var.label_$var -text $var
    pack .font.attr.line1.frame_$var.label_$var
    eval "ext_optionMenu .font.attr.line1.frame_$var.menu_$var \
          curr_$var 25 $fontInfo($var)"
    pack .font.attr.line1.frame_$var.menu_$var
    global curr_$var
    trace variable curr_$var w traceUpdateFW
  }

  frame .font.attr.line2
  pack .font.attr.line2 -anchor nw
  foreach var {ptSz resx resy spc avgWdth rgstry encdng} {
    frame .font.attr.line2.frame_$var
    pack .font.attr.line2.frame_$var -side left
    label .font.attr.line2.frame_$var.label_$var -text $var
    pack .font.attr.line2.frame_$var.label_$var
    eval "ext_optionMenu .font.attr.line2.frame_$var.menu_$var \
          curr_$var 25 $fontInfo($var)"
    pack .font.attr.line2.frame_$var.menu_$var
    global curr_$var
    trace variable curr_$var w traceUpdateFW
  }

  #####################
  ## Aliases
  ##
  frame .font.alias
  pack .font.alias -anchor nw
  label .font.alias.label -text "Aliases:"
  pack .font.alias.label -anchor nw
  listbox .font.alias.box -width 70 -yscrollcommand ".font.alias.scroll set"
  foreach alias $fontInfo(aliases) {
    .font.alias.box insert end $alias
  }
  pack .font.alias.box -side left
  scrollbar .font.alias.scroll -command ".font.alias.box yview"
  pack .font.alias.scroll -expand yes -fill y
  bind .font.alias.box <ButtonRelease> +{boxUpdateFW}

  #####################
  ## Radio choice
  ##
  frame .font.radio
  pack .font.radio -anchor nw
  radiobutton .font.radio.choiceAttr -text "Use attributes" \
      -variable fontChoice -value "attr"
  pack .font.radio.choiceAttr -side left -anchor nw
  bind .font.radio.choiceAttr <ButtonRelease> +{updateFontWidget}
  radiobutton .font.radio.choiceAlias -text "Use alias" \
      -variable fontChoice -value "alias"
  pack .font.radio.choiceAlias -side left -anchor nw
  bind .font.radio.choiceAlias <ButtonRelease> +{updateFontWidget}

  #####################
  ## Full sample?
  ##
  frame .font.fullsample
  pack .font.fullsample -anchor nw
  radiobutton .font.fullsample.yes -text "Long sample" \
      -variable __fontFullSample -value 1
  pack .font.fullsample.yes -side left -anchor nw
  bind .font.fullsample.yes <ButtonRelease> +{updateFontWidget}
  radiobutton .font.fullsample.no -text "Short sample" \
      -variable __fontFullSample -value 0
  pack .font.fullsample.no -side left -anchor nw
  bind .font.fullsample.no <ButtonRelease> +{updateFontWidget}

  #####################
  ## Current selection
  ##
  frame .font.selection
  pack .font.selection -anchor nw
  label .font.selection.sample -justify left -wraplength 500
  pack .font.selection.sample -anchor nw

  #####################
  ## Buttons
  ##
  frame .font.buttons
  pack .font.buttons -side left -anchor sw
  button .font.buttons.ok -text OK -command fontWidgetOK
  pack .font.buttons.ok -side left -anchor sw
  button .font.buttons.cancel -text Cancel -command fontWidgetCancel
  pack .font.buttons.cancel -side left -anchor sw

  #####################
  ## Author
  ##
  button .font.author -text "FontWidget by Jeppe Buk (C) 1996, 1997" \
      -font fixed -relief flat -command aboutFontWidget
  pack .font.author -side right -anchor se

  #####################
  ## Initialization
  ##
  if {$currFont == "*"} {
    set fontChoice attr
    set currFont "-*-*-*-*-*-*-*-*-*-*-*-*-*-*"
  }

  if {[set idx [lsearch -exact $fontInfo(aliases) $currFont]] != -1} {
    set fontChoice alias
    .font.alias.box selection set $idx
    .font.alias.box see $idx
  } else {
    set fontChoice attr
    .font.alias.box selection set 0
    set fontNameList [split $currFont -]
    if {[llength $fontNameList] != 15} {
      error "Invalid font name: $currFont"
    } else {
      set index 1
      foreach var {fndry fmly wght slant swdth adstyl pxlsz ptSz resx \
		       resy spc avgWdth rgstry encdng} {
	if {[lsearch -exact $fontInfo($var) \
		 [lindex $fontNameList $index]] == -1} {
	  error "Invalid $var: [lindex $fontNameList $index]"
	} else {
	  set curr_$var [lindex $fontNameList $index]
	}
	incr index
      }
    }
  }
  updateFontWidget
  tkwait window .font
  return $__result
}

proc traceUpdateFW {name elm op} {
  global fontChoice
  set fontChoice attr
  updateFontWidget
}

proc boxUpdateFW {} {
  global fontChoice
  set fontChoice alias
  updateFontWidget
}

proc updateFontWidget {} {
  global currFont
  global fontChoice
  global __fontExists
  global __fontCharset
  global __fontFullSample
  if {$fontChoice == "alias"} {
    if { [set aliasIndex [lindex [.font.alias.box curselection] 0]] >= 0 } {
      set currFont [.font.alias.box get $aliasIndex]
    } else {
      error "Unknown font alias specified"
    }
  } else {
    set currFont ""
    foreach attr {fndry fmly wght slant swdth adstyl pxlsz ptSz resx \
		      resy spc avgWdth rgstry encdng} {
      global curr_$attr
      append currFont -[set curr_$attr]
    }
  }
  set err [catch {.font.selection.sample configure -font $currFont}]
  if {$err} {
    set __fontExists 0
    .font.selection.sample configure -font fixed \
	-text "$currFont not found"
  } else {
    set __fontExists 1
    if {$__fontFullSample} {
      .font.selection.sample configure \
	  -text "Sample of $currFont:\n$__fontCharset"
    } else {
      .font.selection.sample configure \
	  -text "Sample of $currFont"
    }
  }
}

proc fontWidgetOK {} {
  global __result
  global __mustExist
  global __fontExists
  global currFont
  if {$__fontExists || ($__mustExist == 0)} {
    popGrab
    set __result $currFont
    destroy .font
  } else {
    tk_dialog .fontDialog Error \
  "Font $currFont not found. Please select an existing font or press Cancel" \
  error 0 OK
  }
}

proc fontWidgetCancel {} {
  popGrab
  destroy .font
}

proc aboutFontWidget {} {
  tk_dialog .aboutFontWidget "About FontWidget" \
      "FontWidget for the\nDotfile Generator\n\nby Jeppe Buk (buk@imada.ou.dk)\
\n\nCopyright 1996, 1997" info 0 "OK"
}

###################
## Helper functions
##
proc removeNonIntegers {shouldBeNumbersList} {
  set result {}
  foreach shouldBeNumber $shouldBeNumbersList {
    if {[regexp {[0-9]+} $shouldBeNumber]} {
      lappend result $shouldBeNumber
    }
  }
  return $result
}

proc getFonts {} {
  set result {}
  set path [auto_execok xlsfonts]
  if {$path != 0 && $path != ""} {
    set result [exec xlsfonts]
  } else {
    error "Unable to execute 'xlsfonts', check your path!"
  }
  return [lsort [split $result \n]]
}

proc getFontInfo {} {
  global fontInfo

  set tempWin [makeTempWindow Retrieving]
  label $tempWin.fonts -text "Parsing fonts, please wait..."
  label $tempWin.fontsCount -text "0"
  pack $tempWin.fonts
  pack $tempWin.fontsCount
  update

  set fontsCount 0
  set names [getFonts]
  
  if {$names == {}} {
    error "Unable to find any fonts, 'xlsfonts' returned empty list!"
  } else {
    # The fonts have been found
    set fontInfo(aliases) {}
    set fontInfo(trueNames) {}
    foreach var {fndry fmly wght slant swdth adstyl pxlsz ptSz resx \
		     resy spc avgWdth rgstry encdng} {
      set fontInfo($var) {}
    }
    
    foreach font $names {
      set fontNameList [split $font -]
      if {[llength $fontNameList] != 15} {
	# The font name is an alias
	if {[lsearch -exact $fontInfo(aliases) $font] == -1} {
	  lappend fontInfo(aliases) $font
	}
      } else {
	# The font name is a full X font name
	lappend fontInfo(trueNames) $font
	set index 1
	foreach var {fndry fmly wght slant swdth adstyl pxlsz ptSz resx \
			 resy spc avgWdth rgstry encdng} {
	  if {[lsearch -exact $fontInfo($var) \
		   [lindex $fontNameList $index]] == -1} {
	    lappend fontInfo($var) [lindex $fontNameList $index]
	  }
	  incr index
	}
      }
      incr fontsCount
      if {[expr "$fontsCount % 10"] == 0} {
	$tempWin.fontsCount configure -text $fontsCount
	update
      }
    }

    $tempWin.fontsCount configure -text $fontsCount
    update

    foreach var {fndry fmly wght slant swdth adstyl spc rgstry encdng} {
      set fontInfo($var) "* [lsort $fontInfo($var)]"
    }
    foreach var {pxlsz ptSz resx resy avgWdth} {
      set fontInfo($var) [removeNonIntegers $fontInfo($var)]
      set fontInfo($var) "* [lsort -integer $fontInfo($var)]"
    }
    destroy $tempWin
  }
}
