### 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.
###
### Mar. 14 Japanized by Mahio Motoyama <moto@ba.mbn.or.jp>
###

# 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.

######################################################################
# Fri Feb 20 JST 1998 changed by Mashio Motoyama <moto@ba.mbn.or.jp> #
######################################################################

# 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
#######################################################################
# Fri Feb 20 JST 1998 changed by Mashio Motoyama <moto@ba.mbn.or.jp>
# used for Japanized Tcl/Tk only
#
# Usage: buttonSetText WidgetName Text Font {ascii|kanji|kana}
#
#######################################################################
proc buttonSetText {widget aper font kanjioption} {
    if {$kanjioption == "kanji" || $kanjioption == "kana" } {
	$widget configure -text $aper -kanjifont $font
    } else {
	$widget configure -text $aper
    }
    set err [catch {$widget configure -font $font}]
    if {$err} {
	$widget configure -font fixed
	$widget configure -text "$font (not found)"
    }
}

####################################################################
# Fri Feb 20 JST 1998 changed by Mashio Motoyama <moto@ba.mbn.or.jp>
# used for Japanized Tcl/Tk only
#
# Usage: FontWidget DefaultFont Exist {ascii|kanji|kana}
#
###################################################################
proc FontWidget {defaultFont mustExist kanjioption} {
    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

#####################################
########### CAUTION
    global __fontCharset
    for {set i 32} {$i < 128} {incr i} {
	eval append __fontCharset "\\x[itoh $i] "
#	eval append __fontCharset(ascii) "\\x[itoh $i] "
#	set j [expr (12289 + $i)/16]
#	set k [expr (12289 + $i)%16]
#	set l [hexDigit $j][hexDigit $k]
#	eval append __fontCharset(kanji) "\\x$l"
    }
    

    toplevel .font
    pushGrab local .font

    #####################
    ## Attributes
    ##
    frame .font.attr
    pack .font.attr -anchor nw
    label .font.attr.label -text "フォント構成要素:"
    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 "エイリアス:"
    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 "構成要素で指定" \
	    -variable fontChoice -value "attr"
    pack .font.radio.choiceAttr -side left -anchor nw
    bind .font.radio.choiceAttr <ButtonRelease> +{updateFontWidget}
    radiobutton .font.radio.choiceAlias -text "エイリアスで指定" \
	    -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 "長いサンプル" \
	    -variable __fontFullSample -value 1
    pack .font.fullsample.yes -side left -anchor nw
    bind .font.fullsample.yes <ButtonRelease> +{updateFontWidget}
    radiobutton .font.fullsample.no -text "短いサンプル" \
	    -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 了解 -command fontWidgetOK
    pack .font.buttons.ok -side left -anchor sw
    button .font.buttons.cancel -text 取消 -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 "無効なフォント名: $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 "無効な $var: [lindex $fontNameList $index]"
		} else {
		    set curr_$var [lindex $fontNameList $index]
		}
		incr index
	    }
	}
    }
    updateFontWidget
    tkwait window .font
    return $__result
}

######################################################################
# Fri Feb 20 JST 1998 changed by Mashio Motoyama <moto@ba.mbn.or.jp>
# used for Japanized Tcl/Tk only
######################################################################
proc traceUpdateFW {name elm op}  {
    global fontChoice
    set fontChoice attr
    updateFontWidget
}
#####################################################################
# Fri Feb 20 JST 1998 changed by Mashio Motoyama <moto@ba.mbn.or.jp>
# used for Japanized Tcl/Tk only
######################################################################
proc boxUpdateFW {} {
    global fontChoice
    set fontChoice alias
    updateFontWidget
}
########################################################################
# Fri Feb 20 JST 1998 changed by Mashio Motoyama <moto@ba.mbn.or.jp>
# used for Japanized Tcl/Tk only
#######################################################################
proc updateFontWidget {} {
#    global fontInfo
    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 "フォントエイリアスが定義されていません"
	}
    } 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 が見付かりません"
    } 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"
	}
    }
}

###################################################################
################ 只今考え中 #######################################
#	if {$__fontFullSample} {
#	    if {[regexp "jisx0208" $currFont] || [regexp "jisx0208" $fontInfo(aliases,$currFont)]} {
#		.font.selection.sample configure\
#			-font fixed\
#			-kanjifont $currFont\
#			-text "Sample of $cuurrFont:\n$__fontCharset(kanji)"
#	    } elseif {[regexp "jisx0201-1" $currFont] || [regexp "jisx0201" $fontInfo($currFont)]} {
#		.font.selection.sample configure\
#			-font $currFont\
#			-text "Sample of $__fontCharset(ascii)"
#	    } elseif {[regexp "iso8859-1" $currFont] || [regexp "iso8859-1" $fontInfo($currFont)]} {
#		.font.selection.sample configure\
#			-font $currFont\
#			-text "Sample of:\n$__fontCharset(ascii)"
#	    } else {
#		.font.selection.sample configure\
#			-font $currFont\
#			-text "Sample of:\n$__fontCharset(ascii)"
#	    }	    
#	} else {
#	    if {[regexp "jisx0208" $currFont] || [regexp "jisx0208" $fontInfo($currFont)]} {
#		.font.selection.sample configure\
#			-text "漢字"\
#			-kanjifont $currFont\
#			-font fixed
#	    } elseif {[regexp "jisx0201-1" $currFont] || [regexp "jisx0201" $fontInfo($currFont)]} {
#		.font.selection.sample configure\
#			-text "Katakana"\
#			-font $currFont
#	    } elseif {[regexp "iso8859-1" $currFont] || [regexp "iso8859-1" $fontInfo($currFont)} {
#		.font.selection.sample configure\
#			-text "Sample of $currFont"\
#			-font $currFont
#	    } else {
#		.font.selection.sample configure\
#			-text "Sample of $currFont"\
#			-font $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 \
	"$currFont が見付かりません。\n存在するフォントを選択するか取消ボタンを押してください。" \
  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 "'xlsfonts' が実行できません。パスを確認して下さい。"
  }
  return [lsort [split $result \n]]
}

proc getFontInfo {} {
  global fontInfo

  set tempWin [makeTempWindow Retrieving]
  label $tempWin.fonts -text "フォント解析中。お待ち下さい..."
  label $tempWin.fontsCount -text "0"
  pack $tempWin.fonts
  pack $tempWin.fontsCount
  update

  set fontsCount 0
  set names [getFonts]
  
  if {$names == {}} {
      error "何のフォントも見つかりません。'xlsfonts' は空リストを返しています。"
  } 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
	  }
      }

###########################################
###########################################
#
#      set fd [open /usr/X11/lib/fonts/misc/font.alias r]
#      close $fd
###########################################################
      $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
  }
}
