#!/import/tcl/bin/wish+
# Font selection interface, with hacks for cascaded menus
# Font chapter

# The menus are big, so position the window
# near the upper-left corner of the display
wm geometry . +30+30

# Create a frame and buttons along the top
frame .buttons
pack .buttons -side top -fill x
button .buttons.quit -text Quit -command exit
button .buttons.constrain -text Constrain -command Constrain
button .buttons.reset -text Reset -command Reset
pack .buttons.quit .buttons.constrain .buttons.reset -side right

# An entry widget is used for status messages
entry .buttons.e -textvar status -relief flat
pack .buttons.e -side top -fill x
proc Status { string } {
    global status
    set status $string
    update idletasks
}
# So we can see status messages
tkwait visibility .buttons.e

# Set up a set of menus, one for each
# component of a font name.
frame .menubar
set components {foundry family weight slant swidth \
	adstyle pixels points resx resy \
	space avgWidth registry encoding}
option add *Menubutton.highlightThickness 0
foreach x $components {
    # The border and highlight thickness are set to 0 so the 
    # button texts run together into one long string.
    menubutton .menubar.$x -menu .menubar.$x.m -text -$x \
	-padx 0 -bd 0 -font fixed
    menu .menubar.$x.m
    pack .menubar.$x -side left
    # Create the initial wild card entry for the component
    .menubar.$x.m add radio -label * \
	-variable current($x) \
	-value * \
	-command [list DoFont]
    # font lists all possible component values
    # current keeps the current component values
    set current($x) *
    set font($x) {}
}

# Create a listbox to hold all the font names
frame .body
set list [listbox .body.list \
	-setgrid true \
	-yscrollcommand {.body.scroll set}]
if {$tk_version < 4.0} {
    $list config -geometry 80x10
} else {
    $list config -width 80 -height 10 -selectmode browse
}
scrollbar .body.scroll -command {.body.list yview}
pack .body.scroll -side right -fill y
pack .body.list -side left -fill both -expand true

# Clicking on an item displays the font
bind $list <ButtonRelease-1> [list SelectFont $list %y]

# Use the xlsfonts program to generate a
# list of all fonts known to the server.
Status "Listing fonts..."
if [catch {open "|xlsfonts *"} in] {
	puts stderr "xlsfonts failed $in"
	exit 1
}
set numFonts 0
set numAliases 0
set N 0
while {[gets $in line] >= 0} {
    $list insert end $line
    # allfonts is the master list of existing fonts
    # This is used to avoid potenially expensive
    # searches for fonts on the server, and to
    # highlight the matching font in the listbox
    # when a pattern is specified.
    set allfonts($N) $line
    incr N

    set parts [split $line -]
    if {[llength $parts] < 14} {
	# Aliases do not have the full information
	lappend aliases $line
	incr numAliases
    } else {
	incr numFonts
	# Chop up the font name and record the
	# unique components in the font array.
	# The leading - in font names means that
	# parts has a leading null element and we
	# start at element 1 (not zero).
	set i 1
	foreach x $components {
	    set value [lindex $parts $i]
	    incr i
	    if {[lsearch $font($x) $value] < 0} {
		# Missing this entry, so add it
		lappend font($x) $value
	    }
	}
    }
}
# Create the menus, converting
# any really big menus into cascades
proc AddEntry { menu component value } {
    if {[string length $value] == 0} {
	set label (nil)
    } else {
	set label $value
    }
    $menu add radio -label $label \
	-variable current($component) \
	-value $value \
	-command DoFont
}
set max 30
foreach x $components {
    set len [llength $font($x)]

    set values [lsort $font($x)]
    if {$len > $max} {
	set i 0
	for {set sub 0} {$len > 0} {incr len -$max ; incr sub} {
	    .menubar.$x.m add cascade -menu .menubar.$x.m.$sub \
		-label [lindex $values $i]
	    menu .menubar.$x.m.$sub
	    for {set j 0} {$j < $max} {incr j ; incr i} {
		if {$i >= $len} {
		    break
		}
		AddEntry .menubar.$x.m.$sub $x [lindex $values $i]
	    }
	}
    } else {
	foreach value $values {
	    AddEntry .menubar.$x.m $x $value
	}
    }
}
Status "Found $numFonts fonts and $numAliases aliases"

# This label displays the current font
label .font -textvar curfont -bd 5 -font fixed

# A message displays a string in the font.
set msg [message .msg -aspect 1000 -borderwidth 10]
set sampler "
ABCDEFGHIJKLMNOPQRSTUVWXYZ
abcdefghijklmnopqurstuvwxyz
0123456789
!@#$%^&*()_+-=[]{};:'\"`~,.<>/?\\|
"
set error "

(No matching font)


"
if {0} {
    $msg config -textvar message
    set message $sampler
}
# Now pack the main display
pack .menubar -side top -fill x
pack .body -side top -fill both -expand true
pack .font $msg -side top


proc DoFont {  } {
    global curfont current components
    set curfont {}
    foreach x $components {
	append curfont -$current($x)
    }
    SetFont
}
proc SelectFont { list y } {
    global curfont components current
    set ix [$list nearest $y]
    set curfont [$list get $ix]
    set parts [split $curfont -]
    if {[llength $parts] < 14} {
	foreach x $components {
	    set current($x) {}
	}
    } else {
	set i 1
	foreach x $components {
	    set value [lindex $parts $i]
	    incr i
	    set current($x) $value
	}
    }
    SetFont
}
proc SetFont {} {
    global curfont sampler message error msg allfonts N list
    # Generate a regular expresson from the font pattern
    regsub -all -- {\(nil\)} $curfont {} curfont
    regsub -all -- {\*} $curfont {[^-]*} pattern
    Status $pattern
    for {set n 0} {$n < $N} {incr n} {
	if [regexp -- $pattern $allfonts($n)] {
	    if [catch {$msg config -font $curfont}] {
		puts stderr ">$curfont<"
		puts stderr "!$pattern!"
		Status "Botched match"
	    } else {
		$msg config -text $sampler
		global tk_version
		if {$tk_version < 4.0} {
		    $list select from $n
		    $list select to $n
		    $list  yview $n
		} else {
		    $list select set $n
		    $list see $n
		}
	    }
	    return
	}
    }
    $msg config -text $error
    #set message $sampler
}
proc Constrain {} {
    global curfont allfonts N components

    regsub -all -- {\*} $curfont {[^-]*} pattern

    # Disable all the menu entries first,
    foreach x $components {
	for {set i 2} {1} {incr i} {
	    set j [.menubar.$x.m index $i]
	    if {$j != $i} {
		break	;# Off the end
	    }
	    .menubar.$x.m entryconfigure $i -state disabled
	}
    }

    # Make a pass through the fonts to
    # see if a font enables any entries.

    set z 0
    for {set n 0} {$n < $N} {incr n} {
	set font $allfonts($n)
	if ![regexp -- $pattern $font] {
	    # Font doesn't match, cannot enable anything
	    continue
	}
	incr z
#	puts stderr $font
	set parts [split $font -]
	set p 1
	foreach x $components {
	    set part [lindex $parts $p]
	    incr p
	    ConstrainMenu .menubar.$x.m $part

	}
    }
    puts stderr "Check $z fonts"
}
proc ConstrainMenu { menu part } {
    for {set i 2} {1} {incr i} {
	# Go through the menu entrys to see if any
	# match the current component of the font.
	set j [$menu index $i]
	if {$j != $i} {
	    break	;# Off the end
	}
	if {[$menu type $i] == "cascade"} {
	    $menu entryconfigure $i -state normal
	    ConstrainMenu [$menu entrycget $i -menu] $part
	} else {
	    set value [$menu entrycget $i -value]
	    if {[string compare $value $part] == 0 ||
		[string compare $part *] == 0} {
		$menu entryconfigure $i -state normal
	    }
	}
    }

}

proc Reset {} {
    global components current numFonts
    foreach x $components {
	set current($x) *
    }
    DoFont
    # Enable all the menu entries
    foreach x $components {
	EnableMenu .menubar.$x.m
    }
    Status "$numFonts fonts"
}
proc EnableMenu { menu } {
    for {set i 0} {1} {incr i} {
	set j [$menu index $i]
	if {$j != $i} {
	    break	;# Off the end
	}
	if {[$menu type $i] == "cascade"} {
	    EnableMenu [$menu entrycget $i -menu]
	}
	$menu entryconfigure $i -state normal
    }
}

Reset
