#!/usr/local/bin/wish8.3
# TkFont 1.1 -- Copyright Neil Grant 1996, 1997
# Bug reports, praise, and so on to grantj@sfu.ca

set size 24
set aspect "-0-100-100"
set CurFont "fixed"
set SizedFont "fixed"
set Editor tkedit
set CurFileName ""

proc GetFontList { } {
	.f1.fontlistbox delete 0 end
	update
	set TempFileName "/tmp/fonts.list.[pid]"
	set TempFileName2 "/tmp/fonts.list.[pid]b"

	exec xlsfonts -u -fn "*" | grep "-" | sort -t "-" +2 | uniq > $TempFileName
	exec grep -v "0-0-75-75-" < $TempFileName > $TempFileName2
	exec grep -v "0-0-100-100-" < $TempFileName2 > $TempFileName 
	set Chan [open $TempFileName r]

	set chars 1
	while {$chars > 0} {
		set chars [gets $Chan onefontname]
		.f1.fontlistbox insert end $onefontname
	}
	close $Chan
	.f1.fontlistbox delete end
	exec rm $TempFileName $TempFileName2
}

proc GetFontDirs {} {
	global FontDirList errorCode
	if {[catch {exec xset -q} result] && $errorCode != "NONE"} {
		error $result
	}
	set lines [split $result \n]
	set i [lsearch -exact $lines "Font Path:"]
	if {$i == -1} {
		error "Output of `xset -q' did not contain\
			`Font Path:'\n$result"
	}
	set dirLine [string trim [lindex $lines [incr i]]]
	set FontDirList [split $dirLine ,]
}

proc Rehash {} {
	update
	toplevel .wait
	wm geometry .wait +300+300
	label .wait.lbl -text "Getting info..." -fg red4
	pack .wait.lbl -in .wait
	update
	exec xset fp rehash
	GetFontList
	GetFontDirs
	destroy .wait
}

proc CreateBindings {} {
	bind .f1.fontlistbox <Button-1> {
		.f1.fontlistbox selection clear 0 end
		.f1.fontlistbox selection set [%W index @%x,%y]
		.f1.fontlistbox selection anchor [%W index @%x,%y]
		%W activate @%x,%y
		set CurFont [selection get]
		ShowFont
	}

	bind .fontname <Return> {
		if {![winfo exists .s]} {CreateSampTextWidget}
		.s.sample configure -font $SizedFont
	}

	bind .f1.fontlistbox <Button-3> {
		.f1.fontlistbox selection clear 0 end
		.f1.fontlistbox selection set [%W index @%x,%y]
		.f1.fontlistbox selection anchor [%W index @%x,%y]
		%W activate @%x,%y
		set CurFont [selection get]
		ShowChars
		ShowFont
	}

	bind .f1.fontlistbox <Button-2> {
		.f1.fontlistbox selection clear 0 end
		.f1.fontlistbox selection set [%W index @%x,%y]
		.f1.fontlistbox selection anchor [%W index @%x,%y]
		%W activate @%x,%y
		set CurFont [selection get]
		ShowInfo
		ShowFont
	}
}

proc ShowFont {} {
        global size CurFont SizedFont aspect
	set tsize ${size}${aspect}
	regsub 0-0-0-0 $CurFont $tsize SizedFont
	if {![winfo exists .s]} {CreateSampTextWidget}
	.s.sample configure -font $SizedFont
}

proc ShowChars {} {
	global size CurFont SizedFont aspect
	set tsize $size
	if {$tsize > 24} {set tsize 24}
	set tsize ${tsize}${aspect}
	regsub 0-0-0-0 $CurFont $tsize SizedFont
	exec xfd -fn $SizedFont &
}

proc FindFile {} {
	global FontDirList CurFont CurFileName
	set MangledFont [string range $CurFont 1 end]
	set i 0
	foreach i $FontDirList {
		set result [exec /usr/local/lib/tkfont/FindFont $MangledFont $i/fonts.dir]
		if {[string length $result]} {break}
	}
	set EndOfName [string first " " $result]
	set FontFileName [string range $result 0 [expr $EndOfName-1]]
	set $i "is in $i"
	if {![string length $result]} {
		set FontFileName "It's probably an alias for another font."
		set i "This font couldn't be found."
	}
	set CurFileName "${i}/"
	set CurFileName "${CurFileName}${FontFileName}"
	if {![winfo exists .finddirresults]} {	
		toplevel .finddirresults -relief sunken
		label .finddirresults.fname -anchor w -relief raised
		label .finddirresults.fdir -anchor w -relief raised
		label .finddirresults.file -anchor w -relief raised
		label .finddirresults.size -anchor w -relief raised
		label .finddirresults.name -anchor w -relief raised
		frame .finddirresults.lotsabuttons
		pack .finddirresults.fname .finddirresults.fdir .finddirresults.file \
		     .finddirresults.size .finddirresults.name \
		     .finddirresults.lotsabuttons -in .finddirresults -fill x -expand 1
		button .finddirresults.lotsabuttons.ok -text Ok -command {destroy .finddirresults}
		pack .finddirresults.lotsabuttons.ok  \
			-side left -in .finddirresults.lotsabuttons
		wm title .finddirresults "Font Locator"
		wm resizable .finddirresults 0 0
	}
	.finddirresults.fname configure -text "Font:      $CurFont"
	.finddirresults.fdir configure -text "Directory: $i" -anchor w
	.finddirresults.file configure -text "Filename:  $FontFileName"
	set FileSize [file size $CurFileName]
	.finddirresults.size configure -text "File Size: $FileSize bytes"
	.finddirresults.name configure -text [exec file -z $CurFileName]
}

proc ShowDirs {} {
	global FontDirList
	if {[winfo exists .dirs]} {return}
	
	toplevel .dirs
	listbox .dirs.dirlist -width 40 -height 11 -setgrid 1
	frame .dirs.f1
	radiobutton .dirs.f1.realones -text "Actual" -value 0 -variable Which
	radiobutton .dirs.f1.aliases -text "Aliases" -value 1 -variable Which
	pack .dirs.f1.realones -side left -in .dirs.f1 -expand 1 -fill x
	pack .dirs.f1.aliases -side right -in .dirs.f1 -expand 1 -fill x

	pack .dirs.f1 -in .dirs -fill x -side bottom
	pack .dirs.dirlist -in .dirs -fill both -side top -expand 1
	wm title .dirs "Font Directories"
	set Which 0

	set i 0
	foreach i $FontDirList {
		.dirs.dirlist insert end $i
	}

	bind .dirs.dirlist <Double-1> {Showfontdirectory $Which}
	bind .dirs.dirlist <Double-3> {
		.dirs.dirlist selection clear 0 end
		.dirs.dirlist selection set [%W index @%x,%y]
		.dirs.dirlist selection anchor [%W index @%x,%y]
		%W activate @%x,%y
		Editfontdirectory $Which
	}
}

proc Editfontdirectory {whichone} {
	global Editor
	if {$whichone} {
		if {[file exists [selection get]/fonts.alias]} {
			exec $Editor [selection get]/fonts.alias &
		} else {
			NoAliasFileHere [selection get]
			return
		}
	} else {
		exec $Editor [selection get]/fonts.dir &
	}	
}

proc Showfontdirectory {whichone} {
	set random [clock clicks]
	while {[winfo exists .fontsdir${random}]} {
		set random [clock clicks]
	}

	if {$whichone} {
		if {[file exists [selection get]/fonts.alias]} {
			set Chan [open [selection get]/fonts.alias r]
		} else {
			NoAliasFileHere [selection get]
			return
		}
	} else {
		set Chan [open [selection get]/fonts.dir r]
	}	

	toplevel .fontsdir${random}
	listbox .fontsdir${random}.lst -width 90 -setgrid 1 \
		-yscrollcommand ".fontsdir${random}.scrl set"
	scrollbar .fontsdir${random}.scrl \
		-command ".fontsdir${random}.lst yview"
	set chars 1
		
	while {$chars > 0} {
		set chars [gets $Chan onefontname]
		.fontsdir${random}.lst insert end $onefontname
	}
	close $Chan
	.fontsdir${random}.lst delete 0
	.fontsdir${random}.lst delete end
	pack .fontsdir${random}.scrl -in .fontsdir${random} \
		-side right -fill y
	pack .fontsdir${random}.lst -in .fontsdir${random} \
		-side left -expand 1 -fill both

	if {$whichone} {
		wm title .fontsdir${random} [selection get]/fonts.alias
	} else {
		wm title .fontsdir${random} [selection get]/fonts.dir
	}	
}

proc NoAliasFileHere {dir} {
        tk_dialog .no "Oops" "The directory $dir doesn't have an alias file." "" 0 Ok
}

proc ShowInfo {} {
	global size SizedFont 
	set Info [exec xlsfonts -ll -fn $SizedFont]
	if {![winfo exists .info]} {
		toplevel .info
		text .info.infotext -yscrollcommand ".info.yscroll set" \
		-setgrid 1 -font fixed
		.info.infotext insert end $Info
		scrollbar .info.yscroll -command ".info.infotext yview"
		pack .info.yscroll -in .info -side right -fill y
		pack .info.infotext -in .info -side left -expand 1 -fill both
		wm title .info "Font Information"
	} else {
		.info.infotext delete 0.0 end
		.info.infotext insert end $Info
	}
	.info.infotext configure -state disabled
}

proc About {} {
        tk_dialog .about "About..." "Written by Neil Grant, 1996 & 1997" "" 0 Ok
} 

proc Usage {file} {
	if {![winfo exists .usage]} {
	        toplevel .usage
		wm title .usage Help
		text .usage.helptext -yscrollcommand ".usage.yscroll set" \
			-setgrid 1 -wrap word
		scrollbar .usage.yscroll -command ".usage.helptext yview"
		pack .usage.helptext -in .usage -side left -expand 1 -fill both
		pack .usage.yscroll -in .usage -fill y -side right
	} else {
		.usage.helptext delete 0.0 end
	}
	.usage.helptext insert end [exec cat /usr/local/lib/tkfont/$file]
	.usage.helptext mark set insert 0.0
	.usage.helptext configure -state disabled
}

frame .toprow
menubutton .toprow.file -text File -underline 0 -menu .toprow.file.m -relief raised  -padx 3 -pady 1
menu .toprow.file.m -bd 1 -tearoff 0 -activeborderwidth 1 
.toprow.file.m add command -label "Paste Name" -underline 0 -command {set CurFont [selection get] ; ShowFont}
.toprow.file.m add command -label "Show Info" -underline 5 -command {ShowInfo}
.toprow.file.m add command -label "Show Chars" -underline 5 -command {ShowChars}
.toprow.file.m add command -label "Show Dirs" -underline 5 -command {ShowDirs}
.toprow.file.m add command -label "Find File" -underline 0 -command {FindFile}
.toprow.file.m add command -label "Re-read Fonts" -underline 0 -command {Rehash}
.toprow.file.m add separator
.toprow.file.m add command -label "Exit" -underline 1 -command exit
menubutton .toprow.size -text Sizes -underline 0 -menu .toprow.size.m -relief raised -padx 3 -pady 1
menu .toprow.size.m -bd 1 -tearoff 0 -activeborderwidth 1 
.toprow.size.m add radiobutton -label "12" -value 12 -variable size -command ShowFont
.toprow.size.m add radiobutton -label "14" -value 14 -variable size -command ShowFont
.toprow.size.m add radiobutton -label "18" -value 18 -variable size -command ShowFont
.toprow.size.m add radiobutton -label "24" -value 24 -variable size -command ShowFont
.toprow.size.m add radiobutton -label "36" -value 36 -variable size -command ShowFont
.toprow.size.m add radiobutton -label "48" -value 48 -variable size -command ShowFont
.toprow.size.m add radiobutton -label "72" -value 72 -variable size -command ShowFont
.toprow.size.m add radiobutton -label "96" -value 96 -variable size -command ShowFont
.toprow.size.m add radiobutton -label "144" -value 144 -variable size -command ShowFont
menubutton .toprow.aspect -text Aspect -underline 0 -menu .toprow.aspect.m -relief raised -padx 3 -pady 1
menu .toprow.aspect.m -bd 1 -tearoff 0 -activeborderwidth 1 
.toprow.aspect.m add radiobutton -label "Thinnest" -value "-0-70-100" -variable aspect -command ShowFont
.toprow.aspect.m add radiobutton -label "Thinner" -value "-0-80-100" -variable aspect -command ShowFont
.toprow.aspect.m add radiobutton -label "Thin" -value "-0-90-100" -variable aspect -command ShowFont
.toprow.aspect.m add radiobutton -label "1:1" -value "-0-100-100" -variable aspect -command ShowFont
.toprow.aspect.m add radiobutton -label "Wide" -value "-0-110-100" -variable aspect -command ShowFont
.toprow.aspect.m add radiobutton -label "Wider" -value "-0-120-100" -variable aspect -command ShowFont
.toprow.aspect.m add radiobutton -label "Widest" -value "-0-130-100" -variable aspect -command ShowFont
menubutton .toprow.help -text Help -underline 0 -menu .toprow.help.m -relief raised -padx 3 -pady 1
menu .toprow.help.m -bd 1 -tearoff 0 -activeborderwidth 1 
.toprow.help.m add command -label "About" -command About
.toprow.help.m add command -label "Usage" -command {Usage HelpText.txt}
.toprow.help.m add command -label "Bugs" -command {Usage Bugs.txt}
.toprow.help.m add command -label "File Menu" -command {Usage FileMenu.txt}
.toprow.help.m add command -label "Font Dirs" -command {Usage FontDirs.txt}
.toprow.help.m add command -label "Font Types" -command {Usage FontTypes.txt}
.toprow.help.m add command -label "Copying" -command {Usage COPYING}
.toprow.help.m add command -label "New Features" -command {Usage WhatsNew.txt}
button .toprow.lab -text "TkFont 1.1" -command About -pady 1

proc CreateSampTextWidget { } {
	toplevel .s
	entry .s.sample -bd 2 -relief sunken -width 11
	.s.sample insert 0 "Sample Text"
	pack .s.sample -in .s -fill x
	wm transient .s .
	wm title .s "Sample Text"
}

frame .f1
pack .toprow -side top -fill x
pack .toprow.file -in .toprow -side left
pack .toprow.size -in .toprow -side left
pack .toprow.help -in .toprow -side right
pack .toprow.aspect -in .toprow -side left
pack .toprow.lab -in .toprow -side left -fill x -expand 1
pack .f1 -side top -after .toprow -expand 1 -fill both
listbox .f1.fontlistbox -yscrollcommand ".f1.yscroll set" -setgrid 1 -width 70 
scrollbar .f1.yscroll -command ".f1.fontlistbox yview"
entry .fontname -bd 2 -relief sunken -textvariable SizedFont
pack .f1.fontlistbox -in .f1 -side left -expand 1 -fill both
pack .f1.yscroll -in .f1 -side right -before .f1.fontlistbox -fill y
pack .fontname -side bottom -before .f1.fontlistbox -fill x
wm title . TkFont

Rehash
CreateSampTextWidget
CreateBindings
