#!/bin/sh
# -*- tcl -*- \
    exec wish "$0" "$@"

# Copyright (C) 2001 Robert Fenk
#
# Author:      Robert Fenk
# X-URL:       http://www.robf.de/Hacking/TclTk.html
# X-RCS:       $Id: xfontlist.tk,v 1.4 2003/04/28 19:39:13 fenk Exp $
#
# This code 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 1, 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.

#####################################################################
#
set op {-fg}
proc newColor {value} {
  global op ColorName ColorValue ColorList color
  set value [format \#%02x%02x%02x [.red get] [.green get] [.blue get]]
  .test configure $op $value

  set err [catch {set name $ColorName([.red get] [.green get] [.blue get])}]
  if {$err == 0} {
    set i [lsearch $ColorList $name]
    .l see $i
    set color "$name"
  } else {
    set color {}
  }
}

#####################################################################
#

button .exit -text Exit -command exit

text .test -relief groove -bd 5 -width 20 
scrollbar .sb -command {.l yview} -width 10
listbox .l -bd 2 -relief raised -yscroll {.sb set} -font 7x13 -width 48 \
    -height 35 -setgrid 1

pack .sb -fill y -side left
pack .l -expand 1 -fill both -side left
pack .exit -fill x
pack .test -expand 1 -fill both

#####################################################################
#
set f [open "| xlsfonts"]
while {![eof $f]} {
  .l insert end [gets $f]
}
close $f

for {set i 0} {$i < 255} {incr i} {
  .test insert end [format "%c" $i]
  if {!($i % 20)} {
    .test insert end "\n"
  }
}

#####################################################################
#
bind .l <Button-1> {
  set name [.l get [.l index @%x,%y]]
  .test configure -font $name
}

bind all <q> exit