#!/usr/local/bin/wish -f

###############################
# a simple music database ...
# music doesn't rely on extended tcl, so it should run on any implementation.
#
######## database file ########
# music looks for the database file as "music.db" and ".music_db" in the
# following directories:
#	$HOME $HOME/music $HOME/Music .
# if music doesn't find a db file, it creates one in $HOME/music.db
#
######## bitmap file ##########
# Music looks for the icon bitmap file as "music_icon.bm" in the following
# directories:
#	$HOME $HOME/music $HOME/Music $PATH .
# If it doesn't find it, it doesn't use it.
#
######## searching ########
# the first time text is typed in the search window and return is hit,
# the search starts at the beginning of the list. If return is hit again,
# without changing the text, the search continues with the record after
# the current one.
#
######## bindings #########
# - in any window -
# Next (next screen)		next record
# Prior (previous screen)	previous record
# Find (if you got one)		change focus to search window
# KP_Enter (keypad enter)	Insert a brand-new record (add)
# KP_F4 (keypad PF4 on DEC kp)	delete the current record
#
# - in any main window widget -
# Tab				go to next field
# Shift-Tab			go to previous field
# Right (right arrow)		go one char to right
# Left (left arrow)		go one char to left
#
# - in entry widgets - (not in 'miscellaneous' widget)
# Up (up arrow)			go to previous field
# Down (down arrow)		go to next field
# Return			go to next field
# 
# - in 'miscellaneous' widget -
# Up (up arrow)			go up one line
# Down				go down one line
# Return			insert CR-LF into text
#
######### fonts #########
# I have chosen fonts that you might not have!
# in that case, music should find some that *work*.
# you might want to play around and set prop_font (proportional)
# and fixed_font to things that look nicer
###############################

###############################################################################
# global variable initialization
###############################################################################
set db_file ""
set icon_bitmap ""
set prop_font	"-Adobe-times-medium-r-normal--*-180*"
set fixed_font	"-dec-terminal-medium-r-normal--*-*-*-*-c-*-iso8859-1"
set master_list {}
set record_count -1
set current_rec 0
set cur_rec_changed 0
set compose 0
set combo ""
set adding 0
set any_modify 0
set old_string ""
set listbox_exist 0
set prev_focus ".category.entry"
set category_list {}
set accents {
	{u {\" 252} {\' 250} {\` 249} {\^ 251}}
	{U {\" 220} {\' 218} {\` 217} {\^ 219}}
	{o {\" 246} {\' 243} {\` 242} {\^ 244} {\~ 245} {\/ 248}}
	{O {\" 214} {\' 211} {\` 210} {\^ 213} {\~ 214} {\/ 216}}
	{a {\" 228} {\' 225} {\` 224} {e 230} {\~ 227} {\. 229}}
	{A {\" 196} {\' 193} {\` 192} {E 198} {\~ 195} {\. 197}}
	{n {\~ 241}}
	{N {\~ 209}}
	{e {\' 233} {\` 232} {\" 235} {\^ 234}}
	{E {\' 201} {\` 200} {\" 203} {\^ 202}}
	{C {\, 199}}
	{c {\, 231}}
	{s {s 223}}
	{S {S 223}}
	{i {\' 237} {\` 236} {\" 239} {\^ 238}}
	{I {\' 205} {\` 204} {\" 207} {\^ 206}}
}
foreach ent $accents {
  lappend compose_chars [lindex $ent 0]
}
#################################################################
# subroutines ...
#################################################################
proc QuitApp {} {
  global any_modify

  SaveCurrentIfChanged
  if {$any_modify} {
    if {[Dialog .dialog {Save work first?} {Save modifications?} warning\
      -1 NO YES]} {
      SaveWork
    }
  }
  exit
}

proc SaveWork {} {
  global any_modify
  global db_file master_list

  SaveCurrentIfChanged
  if {$any_modify} {
    set file_id [open $db_file "w"]
    foreach ent $master_list {
      ################################
      # substitute \n's for carriage
      # returns in 'misc' widget
      ################################
      set tmp [lindex $ent 4]
      if {[string length $tmp]} {
        regsub -all "\n" $tmp {\n} tmp
        set ent [lreplace $ent 4 4 $tmp]
      }
      puts $file_id "$ent"
    }
    close $file_id
    set any_modify 0
  }
}

proc GetDefaultFont {} {
  set w ".foo"
  toplevel $w
  #button $w.button -text "test"
  entry $w.e
  set def_font [lindex [$w.e config -font] 3]
  destroy $w
  return $def_font
}

proc TestFont {font} {
  #############
  # see if font can be used...
  #############
  toplevel .testfont
  set result 1
  if {[catch {button .testfont.b -font $font}]} {
    set result 0
  }
  destroy .testfont
  return $result
}

proc AddCategory {cat} {
  ########################
  # add a new category to menu.jump and 'Category' button
  ########################
  global category_list

  set lcat [string tolower $cat]
  .menu.jump.m add command -label "$cat"\
    -command "CatJump {$lcat}"
  .category.label.m add command -label "$cat"\
    -command "
      set category {$lcat}
      set cur_rec_changed 1
      .special.restore config -state normal
    "
}

proc FindFiles {} {
  ##########################################################
  # look for database and icon bitmap files
  ##########################################################
  global db_file icon_bitmap env

  if {[catch {set env(MUSIC_DB)}]} {
    # environment var not set
    foreach dir "$env(HOME) $env(HOME)/music $env(HOME)/Music ." {
      if {[file exists $dir/music.db]} {
        set db_file $dir/music.db
        break
      } elseif {[file exists $dir/.music_db]} {
        set db_file $dir/.music_db
        break
      }
    }
  } else {
    # environment var set
    set db_file $env(MUSIC_DB)
  }
  if {$db_file != ""} {
    puts "setting DATABASE-FILE to $db_file"
  } else {
    puts "DATABASE-FILE not found."
    puts "using $env(HOME)/music.db"
    set db_file $env(HOME)/music.db
  }
  foreach dir "$env(HOME) $env(HOME)/music $env(HOME)/Music\
    [split $env(PATH) {:}] ." {
    if {[file exists $dir/music_icon.bm]} {
      set icon_bitmap $dir/music_icon.bm
      break
    }
  }
  if {$icon_bitmap != ""} {puts "setting ICON-BITMAP to $icon_bitmap"}
}

proc LoadDB {} {
  ############################################################
  # open the database file (if there is one) and load entries
  # into master_list
  ############################################################
  global db_file master_list record_count category_list
  
  if {[file exists $db_file]} {
    exec cp $db_file ${db_file}.bak
    set file_id [open $db_file "r"]
    while {[gets $file_id line] != -1} {
      #########################################
      # insert carriage returns in 'misc' field
      #########################################
      set tmp [lindex $line 4]
      if {[string length $tmp]} {
        regsub -all {\\n} $tmp "\n" tmp
        set line [lreplace $line 4 4 $tmp]
      }
      lappend master_list "$line"
      incr record_count
      if {[expr $record_count % 50] == 0} {
        .message config -text "Loading database ... \[$record_count\]"
        update
      }
    }
    .message config -text "Loading database ... \[$record_count\]"
    update
    close $file_id
  
    .message config -text "Sorting ..."
    update
    set master_list [lsort -command SortCommand $master_list]
    GetCatInfo
  }
  .scale.scale config -from 0 -to $record_count
}

proc GetCatInfo {} {
  ####################################################
  # go through sorted master_list, noting each category
  # and create corresponding menu choices...
  ####################################################
  global master_list start category_list

  catch {unset start}
  set category_list {}
  .message config -text "Compiling information ..."
  update
  set prev ""
  set ind 0
  foreach ent $master_list {
    set cat [lindex $ent 0]
    if {"$cat" != "$prev"} {
      set start($cat) $ind
      AddCategory "$cat"
      lappend category_list "$cat"
    }
    incr ind
    set prev "$cat"
  }
  .message config -text ""
}

proc SortCommand {el1 el2} {
  ##########################################################
  # procedure to sort master_list
  ##########################################################
  return [string compare \
    [string tolower "[lindex $el1 0][lindex $el1 1][lindex $el1 2]"]\
    [string tolower "[lindex $el2 0][lindex $el2 1][lindex $el2 2]"]\
  ]
}

proc StoreDB {} {
  ##########################################################
  # save master_list to file
  ##########################################################
  global db_file master_list

  set file_id [open $db_file "w"]
  foreach entry $master_list {
    puts $file_id "$entry"
  }
  close $file_id
}

proc Tab {list} {
  ##################################
  # selects the next field from list
  ##################################
  set i [lsearch $list [focus]]
  if {$i < 0} {
    set i 0
  } else {
    incr i
    if {$i >= [llength $list]} {
      set i 0
    }
  }
  focus [lindex $list $i]
}

proc ShiftTab {list} {
  ##################################
  # selects the previous field from list
  ##################################
  set i [lsearch $list [focus]]
  if {$i < 0 } {
    set i 0
  } else {
    set i [expr $i - 1]
    if {$i < 0} {
      set i [expr [llength $list] - 1]
    }
  }
  focus [lindex $list $i]
}

proc StandardEntryBinding {win} {
  ############################################
  # these are the standard bindings for all 'entry' widgets
  # in the main window
  ############################################
  global main_tablist prev_focus

  bind $win <Tab> "Tab \$main_tablist"
  bind $win <Shift-Tab> "ShiftTab \$main_tablist"
  bind $win <Shift-Right> {MoveForward 10}
  bind $win <Shift-Left> {MoveBackward 10}
  bind $win <Next> {MoveForward 1}
  bind $win <Prior> {MoveBackward 1}
  bind $win <Down> "Tab \$main_tablist"
  bind $win <Up> "ShiftTab \$main_tablist"
  bind $win <KP_Enter> {AddRecord}
  bind $win <KP_F4> {AskDeleteRecord}
  bind $win <Find> {focus .search.entry}
  bind $win <FocusOut> "set prev_focus $win"
  bind $win <Control-u> "
    $win delete 0 end
    set cur_rec_changed 1
    .special.restore config -state normal
  "
  bind $win <Control-w> "
    if {\[string length \[$win get\]\]} {
      set seb_sub \[string range \[$win get\] 0 \[$win index insert\]\]
      set seb_last \[string last { } \$seb_sub\]
      if {\$seb_last == -1} {
        set set_last 0
      }
      $win delete \$seb_last \[$win index insert\]
      set cur_rec_changed 1
      .special.restore config -state normal
    }
  "
}

proc StandardTextBinding {win} {
  #########################################
  # the standard bindings for the text 'misc' widget
  #########################################
  global main_tablist prev_focus

  bind $win <Tab> "Tab \$main_tablist"
  bind $win <Shift-Tab> "ShiftTab \$main_tablist"
  bind $win <Shift-Right> {MoveForward 10}
  bind $win <Shift-Left> {MoveBackward 10}
  bind $win <Next> {MoveForward 1}
  bind $win <Prior> {MoveBackward 1}
  bind $win <KP_Enter> {AddRecord}
  bind $win <KP_F4> {AskDeleteRecord}
  bind $win <Find> {focus .search.entry}
  bind $win <FocusOut> "set prev_focus $win"
}

proc MoveForward {units} {
  ########################################
  # gets called to jump $units records ahead
  ########################################
  global current_rec record_count master_list

  if {![SaveCurrentIfChanged]} {return}
  if {([expr $current_rec + $units]) < $record_count} {
    set current_rec [expr $current_rec + $units]
  } else {
    set current_rec $record_count
  }
  UpdateDisplay
}

proc MoveBackward {units} {
  ########################################
  # gets called to jump $units records back
  ########################################
  global current_rec record_count master_list

  if {![SaveCurrentIfChanged]} {return}

  if {([expr $current_rec - $units]) > 0} {
    set current_rec [expr $current_rec - $units]
  } else {
    set current_rec 0
  }
  UpdateDisplay
}

proc SaveCurrentIfChanged {} {
  #############################################
  # this routine gets called BEFORE a different
  # record is displayed
  #############################################
  global cur_rec_changed current_rec adding any_modify

  set return 1
  if {$cur_rec_changed} {
    Message "Saving ..." {-1}
    set any_modify 1
    set return [SaveCurrentRecord]
  }
  Message {} {}
  return $return
}

proc CancelAdd {} {
  ##############################################
  # this throws away the current record being inserted
  ##############################################
  global current_rec

  pack forget .special.cancel
  UpdateDisplay
}

proc IncrementStartPointers {start_index} {
  #############################################
  # this decrements each start() pointer after
  # the current category
  #############################################
  global start category_list

  while {$start_index < [llength $category_list]} {
    incr start([lindex $category_list $start_index])
    incr start_index
  }
}

proc InsertRecord {} {
  ###############################################
  # insert a record into master_list
  ###############################################
  global master_list category_list start current_rec record_count
  global category composer title orchestra cdnum reserved
  global listbox_exist any_modify

  set entry "{$category} {$composer} {$title} {$orchestra}\
    {[.misc.text get 0.0 end]} {$cdnum} {$reserved}"

  ## Is category new or does it exist?
  if {[lsearch $category_list $category] == -1} {
    ## new category
    set category_index 0
    ## find where category fits into category_list
    while {($category_index < [llength $category_list])&&
           ($category > [lindex $category_list $category_index])} {
      incr category_index
    }
    if {$category_index < [llength $category_list]} {
      ## didn't go to end of category_list
      set start($category) $start([lindex $category_list $category_index])
      set category_list [linsert $category_list $category_index $category]
      ## leave category_index pointing at the next category after new one
      incr category_index
      RebuildCatMenus
      IncrementStartPointers $category_index
    } else {
      ## oops, went to end of category_list
      set start($category) [expr $record_count + 1]
      lappend category_list $category
      RebuildCatMenus
    }
    set master_list [linsert $master_list $start($category) $entry]
    set listbox_index $start($category)
  } else {
    ## the category exists ...
    set category_index [lsearch $category_list $category]
    ## set the starting record from the start() pointer for this category
    set master_index $start($category)
    IncrementStartPointers [expr $category_index + 1]
    ## compare until reach end of list or until fits
    while {($master_index <= $record_count)&&
           ([SortCommand $entry [lindex $master_list $master_index]] == 1)} {
      incr master_index
    }
    set master_list [linsert $master_list $master_index $entry]
    set listbox_index $master_index
  }
  incr record_count
  set any_modify 1
  if {$listbox_exist} {
    .list.f.lb insert $listbox_index [ListFormat $entry]
  }
  .scale.scale config -from 0 -to $record_count
}

proc UpdateDisplay {} {
  ###########################################
  # updates the fiels in the main window to the
  # values of the current record ($current_rec)
  # If the cursor in the text widget is not visible,
  # it makes it so. The same for the current record
  # in the listbox
  ###########################################
  global master_list current_rec listbox_exist
  global category title composer orchestra cdnum reserved cur_rec_changed

  set entry [lindex $master_list $current_rec]
  set category [lindex $entry 0]
  set composer [lindex $entry 1]
  set title [lindex $entry 2]
  set orchestra [lindex $entry 3]
  set cdnum [lindex $entry 5]
  set reserved [lindex $entry 6]
  .misc.text delete 0.0 end
  .misc.text insert 0.0 [lindex $entry 4]
  .scale.scale set $current_rec
  .misc.text yview -pickplace insert
  if {$listbox_exist} {
    .list.f.lb select from $current_rec
    set get_list [.list.f.sb get]
    if {([lindex $get_list 2] > $current_rec)||
        ([lindex $get_list 3] < $current_rec)} {
      .list.f.lb yview [expr $current_rec - 10]
    }
  }
}

proc CatJump {cat} {
  #########################################
  # using the pointer in start(), jumps to the beginning
  # of the select category
  #########################################
  global master_list current_rec record_count start

  .message config -text "Jumping ..."
  update
  if {![SaveCurrentIfChanged]} {return}
  set current_rec $start($cat)
  .message config -text ""
  UpdateDisplay
}

proc ScaleChange {num} {
  #########################################
  # this gets called when the scale in the main win
  # is slid to update the current_rec
  #########################################
  global current_rec cur_rec_changed

  if {![SaveCurrentIfChanged]} {UpdateDisplay; return}
  set current_rec $num
  UpdateDisplay
}

proc SaveCurrentRecord {} {
  #########################################
  # this only gets called from SaveCurrentIfChanged.
  # it has to deal with the case of a new record being added
  # (in which case the global var 'adding' is set to 1) as well
  # as when the current record has been changed.  If the current
  # record has been changed, it checks if any of category, title, or
  # composer has changed. If so, it deletes the current record
  # and re-inserts it using InsertRecord. If not, it simple
  # does a lreplace to save cpu cycles.
  #########################################
  global current_rec cur_rec_changed master_list start record_count
  global category title composer orchestra cdnum reserved cur_rec_changed
  global category_list adding

  set prev_cat [lindex [lindex $master_list $current_rec] 0]
  set prev_com [lindex [lindex $master_list $current_rec] 1]
  set prev_tit [lindex [lindex $master_list $current_rec] 2]

  # special check for first time ever
  if {(!$adding)&&($record_count<0)} {return 1}
  if {[lsearch $category_list $category] == -1} {
    if {![Dialog .dialog {New Category?} "The category $category does not\
      exist. Do you want to create it?" warning -1 {NO} {YES}]} {
      Message "choose an existing category" {3000}
      return 0
    }
  }
  if {!$adding} {
    # do the comparisons to determine if I have to delete and re-insert
    # somewhere else
    if {($prev_cat != $category)||($prev_tit != $title)||
        ($prev_com != $composer)} {
      # something changed, needs to be re-inserted
      DeleteRecord
      InsertRecord
    } else {
      # can stay put
      set entry "{$category} {$composer} {$title} {$orchestra}\
	{[.misc.text get 0.0 end]} {$cdnum} {$reserved}"
      set master_list [lreplace $master_list $current_rec $current_rec $entry]
    }
  } else {
    # this is a new record so I only need to call InsertRecord
    InsertRecord
    pack forget .special.cancel
    set adding 0
  }
  set cur_rec_changed 0
  .special.restore config -state disabled
  return 1
}

proc RebuildCatMenus {} {
  ###############################################
  # gets called when a new category has been created
  ###############################################
  global category_list

  puts "RebuildCatMenus: cat-list=$category_list"
  .menu.jump.m delete 0 last
  .category.label.m delete 0 last

  foreach cat $category_list {
    AddCategory "$cat"
  }
}

proc MakeMenu {} {
  #################################################################
  # deal with the menu stuff at the top of main window
  #################################################################
  global category_list

  frame .menu -relief raised -borderwidth 1
  pack .menu -side top -fill x
  # 'file' choice
  menubutton .menu.file -text "File" -menu .menu.file.m
  menu .menu.file.m
  .menu.file.m add command -label "Print" -command "Print"
  .menu.file.m add separator
  .menu.file.m add command -label "Save" -command "SaveWork"
  .menu.file.m add command -label "Quit" -command "QuitApp"
  # 'records' choice
  menubutton .menu.records -text "Records" -menu .menu.records.m
  menu .menu.records.m
  .menu.records.m add command -label "Add\t(KP Enter)" -command "AddRecord"
  .menu.records.m add command -label "Delete\t(PF4)" -command "AskDeleteRecord"
  # 'output' choice
  menubutton .menu.output -text "List" -menu .menu.output.m
  menu .menu.output.m
  .menu.output.m add command -label "Screen" -command "MakeListbox"
  # 'jump' choice
  menubutton .menu.jump -text "Jump" -menu .menu.jump.m
  menu .menu.jump.m
  # 'search' choice
  pack .menu.records .menu.output .menu.jump -side left
  pack .menu.file -side right
  tk_menuBar .menu .menu.records .menu.output .menu.jump .menu.search .menu.file
}

#################################################################
# build the main window (whew!)
#################################################################
proc MainWin {} {
  global category title composer orchestra misc cdnum reserved prop_font
  global record_count main_tablist listbox_exist
  global category_list cur_rec_changed icon_bitmap

  bind . <Right> {MoveForward 1}
  bind . <Left> {MoveBackward 1}
  bind . <Map> { if {$listbox_exist} {wm deiconify .list} }
  bind . <Unmap> { if {$listbox_exist} {wm iconify .list} }
  #bind . <FocusOut> {if {![string compare %W .]} {set prev_focus [focus]}}
  bind . <FocusIn> {focus $prev_focus}
  if {$icon_bitmap != ""} {wm iconbitmap . @$icon_bitmap}
  StandardTextBinding .
  set main_tablist ".category.entry .composer.entry .title.entry\
    .orchestra.entry .misc.text .cdnum.entry"
  ###
  # search
  ###
  frame .search -bd 1m
  entry .search.entry -rel sunk -width 20 -textvar searchvar
  label .search.label -text "Search String:" -rel raised
  label .search.placehold -rel flat -width 30
  pack .search.entry -side right
  pack .search.label -side right
  pack .search.placehold -side left -fill x
  bind .search.entry <Return> {Search $searchvar}
  bind .search.entry <Tab> {focus .category.entry}
  bind .search.entry <Shift-Tab> {focus .cdnum.entry}
  bind .search.entry <Shift-Right> {MoveForward 10}
  bind .search.entry <Shift-Left> {MoveBackward 10}
  bind .search.entry <Next> {MoveForward 1}
  bind .search.entry <Prior> {MoveBackward 1}
  bind .search.entry <Down> {focus .category.entry}
  bind .search.entry <Up> {focus .cdnum.entry}
  bind .search.entry <KP_Enter> {AddRecord}
  bind .search.entry <KP_F4> {DeleteRecord}
  bind .search.entry <KeyPress> "SearchInput .search.entry %A %K"
  ###
  # Category
  ###
  frame .category -bd 1m
  menubutton .category.label -text "Category" -width 15 -rel raised\
  	-menu .category.label.m
  menu .category.label.m
  ##
  entry .category.entry -rel sunk -width 40 -textvariable category\
    -font $prop_font
  pack .category.label .category.entry -side left
  StandardEntryBinding .category.entry
  bind .category.entry <Return> "Tab \$main_tablist"
  bind .category.entry <KeyPress> "EntryInput .category.entry %A %K"
  ####
  # composer
  ####
  frame .composer -bd 1m
  label .composer.label -text "Composer/Group" -width 15 -rel raised
  entry .composer.entry -rel sunk -width 40 -textvariable composer\
    -font $prop_font
  pack .composer.label .composer.entry -side left
  StandardEntryBinding .composer.entry
  bind .composer.entry <Return> "Tab \$main_tablist"
  bind .composer.entry <KeyPress> "EntryInput .composer.entry %A %K"
  bind .composer.entry <KeyPress> "EntryInput .composer.entry %A %K"
  ####
  # title
  ####
  frame .title -bd 1m
  label .title.label -text "Title" -width 15 -rel raised
  entry .title.entry -rel sunk -width 40 -textvariable title\
    -font $prop_font
  pack .title.label .title.entry -side left
  StandardEntryBinding .title.entry
  bind .title.entry <Return> "Tab \$main_tablist"
  bind .title.entry <KeyPress> "EntryInput .title.entry %A %K"
  bind .title.entry <KeyPress> "EntryInput .title.entry %A %K"
  ####
  # orchestra
  ####
  frame .orchestra -bd 1m
  label .orchestra.label -text "Orchestra" -width 15 -rel raised
  entry .orchestra.entry -rel sunk -width 40 -textvariable orchestra\
    -font $prop_font
  pack .orchestra.label .orchestra.entry -side left
  StandardEntryBinding .orchestra.entry
  bind .orchestra.entry <Return> "Tab \$main_tablist"
  bind .orchestra.entry <KeyPress> "EntryInput .orchestra.entry %A %K"
  bind .orchestra.entry <KeyPress> "EntryInput .orchestra.entry %A %K"
  ####
  # misc
  ####
  frame .misc -bd 1m
  frame .misc.labf; # -background green
  pack .misc.labf -side left
  label .misc.labf.label -text "Miscellaneous" -width 15 -rel raised
  label .misc.labf.foo -rel flat
  pack .misc.labf.label .misc.labf.foo -side top
  #entry .misc.entry -rel sunk -width 40 -textvariable misc
  text .misc.text -rel sunk -bd 2 -height 5 -width 38 -wrap word\
    -font $prop_font -yscrollcommand ".misc.sb set"
  scrollbar .misc.sb -rel sunk -command ".misc.text yview"
  pack .misc.labf .misc.text -side left
  pack .misc.sb -side right -fill y
  StandardTextBinding .misc.text
  bind .misc.text <KeyPress> "TextInput .misc.text %A %K"
  ####
  # cd number
  ####
  frame .cdnum -bd 1m
  label .cdnum.label -text "CD Number" -width 15 -rel raised
  entry .cdnum.entry -rel sunk -width 40 -textvariable cdnum\
    -font $prop_font
  pack .cdnum.label .cdnum.entry -side left
  StandardEntryBinding .cdnum.entry
  bind .cdnum.entry <Return> "Tab \$main_tablist"
  bind .cdnum.entry <KeyPress> "EntryInput .cdnum.entry %A %K"
  bind .cdnum.entry <KeyPress> "EntryInput .cdnum.entry %A %K"
  ####
  # special
  ####
  frame .special -bd 1m
  button .special.cancel -background red -text "CANCEL ADD"\
    -command {CancelAdd}
  button .special.restore -text "Discard Changes" -command {
    UpdateDisplay
    set cur_rec_changed 0
    .special.restore config -state disabled
  } -state disabled
  pack .special.restore -side left -expand 1 -padx 5m
  ####
  # message
  ####
  message .message -bd 1m -font $prop_font -width 4i -aspect 800\
    -text "Loading database ..." -foreground red
  ####
  # scale
  ####
  frame .scale -bd 1m
  scale .scale.scale -from 0 -to $record_count -showvalue 1 -orient\
    horizontal -length 4i -command {ScaleChange}
  button .scale.back -text "<--" -command {MoveBackward 1}
  button .scale.forward -text "-->" -command {MoveForward 1}
  #pack .scale.scale -side top -fill x
  pack .scale.back -padx 3m -pady 3m -side left
  pack .scale.scale -side left
  pack .scale.forward -padx 3m -pady 3m -side left
  ####
  # buttons
  ####
  #frame .buttons -bd 1m; # -background green
  #button .buttons.back -text "<--" -command {MoveBackward 1}
  #button .buttons.forward -text "-->" -command {MoveForward 1}
  #pack .buttons.back -side left -expand 1 -padx 30m
  #pack .buttons.forward -side right -expand 1 -padx 30m
  ##########
  pack .search .category .composer .title .orchestra\
    .misc .cdnum .special .message .scale -side top
  tkwait visibility .message
  #############################################################################
}

proc Message {msg duration} {
  ########################################
  # print a message in red in the message field of main window
  # if $duration == "", deletes an old message
  # if $duration  >  0, creates a message for $duration man milliseconds
  # if $duration == -1, create message but doesn't delete it
  ########################################

  if {$duration == ""} {
    .message config -text ""
    return
  }
  .message config -text "$msg"
  update
  if {$duration != -1} {after $duration ".message config -text {}"}
}

proc Print {} {
  ###################################################
  # very basic output to file.
  # the hooks PrintPrologue and PrintEpilogue are
  # there in case I ever decide to make it PostScript
  # or even *roff capable. At the moment they don't do
  # anything
  ###################################################
  global master_list prop_font print_var print_file

  set print_var ""
  set w ".print"  
  set prev_cat ""

  set dashes ""
  set count 0
  while {$count < 78} {
    append dashes "-"
    incr count
  }
  toplevel $w
  label $w.lab -text "Enter filename to print to:" -font $prop_font
  entry $w.ent -width 30 -textvar print_file -rel sunk -font $prop_font
  frame $w.buttons -bd 1m
  button $w.buttons.cancel -text "Cancel" -command "destroy $w"
  button $w.buttons.print -text "Print" -command {set print_var 1}
  pack $w.buttons.print $w.buttons.cancel -expand 1 -padx 5m -side left
  pack $w.lab $w.ent $w.buttons -side top
  tkwait variable print_var
  if {[string length $print_file]} {
    if {[catch {set file_id [open $print_file "w"]}]} {
      Message "couldn't open $print_file for writing" {3000}
    } else {
      PrintPrologue $file_id
      foreach entry $master_list {
        if {[lindex $entry 0] != $prev_cat} {
          puts $file_id ""
          puts $file_id "[lindex $entry 0]"
          puts $file_id "$dashes"
        }
        puts $file_id "[PrintFormat $entry]"
        set prev_cat [lindex $entry 0]
      }
      PrintEpilogue $file_id
      close $file_id
    }
  }
  destroy $w
}

proc PrintFormat {entry} {
  ####################################
  # format the lines for printing
  ####################################
  return [format "%-21s%-39s%-20s"\
    [string range [lindex $entry 1] 0 20]\
    [string range [lindex $entry 2] 0 37]\
    [string range [lindex $entry 2] 0 19]]
}

proc PrintPrologue {file_id} {
}

proc PrintEpilogue {file_id} {
}

proc AskDeleteRecord {} {
  #####################################
  # a wrapper for DeleteRecord for a
  # user-requested delete
  #####################################

  if {![Dialog .delete {DELETE!} {Do you REALLY want to delete this one???}\
	warning {} {NO} {YES}]} {
    return
  }
  DeleteRecord
  UpdateDisplay
}

proc DeleteRecord {} {
  global current_rec record_count master_list category_list start
  global listbox_exist any_modify

  set cat [lindex [lindex $master_list $current_rec] 0]
  set master_list [lreplace $master_list $current_rec $current_rec]
  set record_count [expr $record_count - 1]
  set cat_ind [expr [lsearch $category_list $cat] + 1]

  #
  # the following decrements the start pointers after the
  # current category
  #
  while {$cat_ind < [llength $category_list]} {
    set start([lindex $category_list $cat_ind])\
      [expr $start([lindex $category_list $cat_ind]) - 1]
    incr cat_ind
  }
  set any_modify 1
  if {$listbox_exist} {
    .list.f.lb delete $current_rec
  }
  .scale.scale config -from 0 -to $record_count
}

proc MakeListbox {} {
  ###################################################
  # if this gets called when the listbox already exists,
  # if the listbox is iconified, then I de-iconfify it. If
  # it is simply buried by other windows, I iconify/de-iconify
  # it to make it the active window
  ###################################################
  global master_list current_rec record_count fixed_font listbox_exist

  if {$listbox_exist} {
    if {[wm state .list] == "iconic"} {
      wm deiconify .list
    }
    wm iconify .list
    wm deiconify .list
    return
  }
  set listbox_exist 1
  set w ".list"
  catch {destroy $w}
  toplevel $w
  frame $w.f -background red
  listbox $w.f.lb -rel sunk -yscroll "$w.f.sb set" -font $fixed_font\
    -geom 40x30 -setgrid 1
  tk_listboxSingleSelect $w.f.lb
  scrollbar $w.f.sb -rel sunk -command "$w.f.lb yview"
  pack $w.f.sb -side right -fill y -expand yes
  pack $w.f.lb -side left -expand yes -fill both
  frame $w.buttons -bd 1m
  button $w.buttons.vanish -text "Vanish"\
    -command "destroy $w; set listbox_exist 0"
  pack $w.buttons.vanish -expand 1 -padx 5m
  pack $w.f -side top -fill y -expand yes
  pack $w.buttons -side bottom
  foreach entry $master_list {
    $w.f.lb insert end [ListFormat $entry]
  }
  bind $w.f.lb <Double-1> "
    if {\[SaveCurrentIfChanged\]} {
      set current_rec \[$w.f.lb curselect\]
      UpdateDisplay
    }
  "
  $w.f.lb select from $current_rec
  $w.f.lb yview $current_rec
}

proc ListFormat {entry} {
  ##########################################
  # formats records for the listbox
  ##########################################
  return [format "%-7s %-15s %-15s"\
    [string range [lindex $entry 0] 0 5]\
    [string range [lindex $entry 1] 0 13]\
    [string range [lindex $entry 2] 0 13]]
}

proc Search {string} {
  ##########################################
  # the search is case-independent and searches all fields
  ##########################################
  global master_list current_rec search_string record_count
  global old_string cur_rec_changed

  if {![SaveCurrentIfChanged]} {return}
  if {[string length $string]} {
    set string [string tolower $string]
    if {$old_string != $string} {
      set start 0
    } else {
      set start [expr $current_rec + 1]
    }
    Message "Searching for $string ..." {1000}
    set count 0
    foreach entry $master_list {
      if {($count >= $start)&&([regexp "$string" [string tolower $entry]])} {
        break
      }
      incr count
    }
    if {$count != [expr $record_count + 1]} {
      set current_rec $count
      UpdateDisplay
    } else {
      Message "string $string not found" {2000}
    }
  }
  set old_string $string
}

proc AddRecord {} {
  global current_rec record_count master_list adding
  global category composer title orchestra cdnum reserved

  if {$adding} {set clear_fields 0} else {set clear_fields 1}
  if {![SaveCurrentIfChanged]} {return}
  ###
  # first, clear out form ...
  ###
  if {$clear_fields} {
    ## clear all fields if first time through
    set category  ""
    set composer  ""
    set title     ""
    set orchestra ""
    set cdnum     ""
    set reserved  ""
  } else {
    ## if this is not first time in add, leave some (possible) useful
    ## fields as they were
    set title     ""
    set cdnum     ""
  }
  .misc.text delete 0.0 end
  #####
  pack .special.cancel -side right
  #focus .category.entry
  update
  set adding 1
}

proc Dialog {w title text bitmap default args} {
  #################################################
  # generic Dialog window (stolen straight from book)
  #################################################
  global dialog_button prop_font
  
  toplevel $w -class Dialog
  wm geometry $w +400+400
  wm title $w $title
  wm iconname $w Dialog
  frame $w.top -relief raised -bd 1
  pack $w.top -side top -fill both
  frame $w.bot -relief raised -bd 1
  pack $w.bot -side bottom -fill both

  message $w.top.msg -width 3i -text $text -font $prop_font
  pack $w.top.msg -side right -expand 1 -fill both -padx 5m -pady 5m
  if {$bitmap != ""} {
    label $w.top.bitmap -bitmap $bitmap
    pack $w.top.bitmap -side left -padx 5m -pady 5m
  }
  set i 0
  foreach but $args {
    button $w.bot.button$i -text $but -command "set dialog_button $i"
    if {$i == $default} {
      frame $w.bot.default -relief sunken -bd 1
      pack $w.bot.default -side left -expand 1 -padx 5m -pady 2m
      pack $w.bot.button$i -in $w.bot.default -side left \
        -padx 3m -pady 3m -ipadx 2m -ipady 1m
    } else {
      pack $w.bot.button$i -side left -expand 1 \
        -padx 5m -pady 5m -ipadx 2m -ipady 1m
    }
    incr i
  }
  if {$default > 0} {
    bind $w <Return> "$w.bot.button$default flash; set dialog_button $default"
  }
  set oldFocus [focus]
  tkwait visibility $w
  grab $w
  focus $w
  tkwait variable dialog_button
  # wait for user to respond
  destroy $w
  focus $oldFocus
  return $dialog_button
}

#####################################
## now routines for handling KeyPress events in the main window
#####################################

proc EntryInput {win char keysym} {
  global cur_rec_changed compose combo compose_chars accents
  if {([regexp {[a-zA-Z0-9]} $char])||([regexp {[ ~`!@#$%^&*()]} $char])||
      ([regexp {[-+=]} $char])||([regexp {[|"';:?/.><,]} $char])||
      ([regexp {[][_]} $char])} {
    if {$compose} {
      if {$combo == ""} {
        if {[lsearch $compose_chars $char] >= 0} {
          set combo [lsearch $compose_chars $char]
        } else {
          puts -nonewline "\007"
          set compose 0
        }
      } else {
        foreach foo [lreplace [lindex $accents $combo] 0 0] {
          if {$char == [lindex $foo 0]} {
            $win insert insert [format "%c" [lindex $foo 1]]
            break
          }
        }
        set compose 0
        set combo ""
      }
    } else {
      $win insert insert $char
    }
    set cur_rec_changed 1
    .special.restore config -state normal
  } else {
    switch $keysym {
      Delete {
        $win delete [expr [$win index insert] - 1]
        set cur_rec_changed 1
        .special.restore config -state normal
      }
      Left "$win icursor [expr [$win index insert] - 1]"
      Right "$win icursor [expr [$win index insert] + 1]"
      Alt_L -
      Multi_key "set compose 1"
      braceleft -
      braceright {Message "YOU aren't allowed to type that char!" 2000}
    }
  }
}

proc SearchInput {win char keysym} {
  global compose combo compose_chars accents
  if {([regexp {[a-zA-Z0-9]} $char])||([regexp {[ ~`!@#$%^&*()]} $char])||
      ([regexp {[-+=]} $char])||([regexp {[|"';:?/.><,]} $char])||
      ([regexp {[][_]} $char])} {
    if {$compose} {
      if {$combo == ""} {
        if {[lsearch $compose_chars $char] >= 0} {
          set combo [lsearch $compose_chars $char]
        } else {
          puts -nonewline "\007"
          set compose 0
        }
      } else {
        foreach foo [lreplace [lindex $accents $combo] 0 0] {
          if {$char == [lindex $foo 0]} {
            $win insert insert [format "%c" [lindex $foo 1]]
            break
          }
        }
        set compose 0
        set combo ""
      }
    } else {
      $win insert insert $char
    }
  } else {
    switch $keysym {
      Delete {
        $win delete [expr [$win index insert] - 1]
      }
      Left "$win icursor [expr [$win index insert] - 1]"
      Right "$win icursor [expr [$win index insert] + 1]"
      Alt_L -
      Multi_key "set compose 1"
      braceleft -
      braceright {Message "YOU aren't allowed to type that char!" 2000}
    }
  }
}

proc TextInput {win char keysym} {
  global cur_rec_changed compose combo compose_chars accents
  if {($char != "")&&(([string length $keysym] == 1)||
                      ([regexp {[~!@#$%^&*_]} $char])||
                      ([regexp {[()]} $char])||
                      ([regexp {[=+|'";`-]} $char])||
                      ([regexp {[][:><?/\\.,]} $char]))} {
    if {$compose} {
      if {$combo == ""} {
        if {[lsearch $compose_chars $char] >= 0} {
          set combo [lsearch $compose_chars $char]
        } else {
          puts -nonewline "\007"
          set compose 0
        }
      } else {
        foreach foo [lreplace [lindex $accents $combo] 0 0] {
          if {$char == [lindex $foo 0]} {
            $win insert insert [format "%c" [lindex $foo 1]]
            break
          }
        }
        set compose 0
        set combo ""
      }
    } else {
      $win insert insert $char
      set cur_rec_changed 1
      .special.restore config -state normal
    }
  } else {
    switch $keysym {
      Return {$win insert insert "\n"; set cur_rec_changed 1
              .special.restore config -state normal}
      Delete {$win delete insert-1c; set cur_rec_changed 1
              .special.restore config -state normal}
      space {$win insert insert " "; set cur_rec_changed 1
             .special.restore config -state normal}
      Up {$win mark set insert insert-1l}
      Down {$win mark set insert insert+1l}
      Right {$win mark set insert insert+1c}
      Left {$win mark set insert insert-1c}
      Alt_L -
      Multi_key "set compose 1"
      braceleft -
      braceright {Message "YOU aren't allowed to type that char!" 2000}
    }
  }
  $win yview -pickplace insert
}

###############################################################################
# End of subroutines! prog starts ...
###############################################################################

#######
# see if my default fonts are there ...
#######
if {![TestFont $prop_font]} {
  set prop_font [GetDefaultFont]
}
if {![TestFont $fixed_font]} {
  set fixed_font [GetDefaultFont]
}
FindFiles;		# get locations for database & icon files
MakeMenu;		# set up menus
MainWin;		# setup main window
update;			# force server to display what's been done
LoadDB;			# load from database file
UpdateDisplay;		# display first record in main win
.message config -text "";		# turn off any startup messages
bind all <Next> {MoveForward 1};	# set up global bindings for next-page
bind all <Prior> {MoveBackward 1};	# and prev-page
