# Font dialog module.
# Rick Smereka, Copyright (C) 2004-2005.

# 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, get a copy via the Internet at
# http://gnu.org/copyleft/gpl.html or write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA 02111-1307 USA

# You can contact the author via email at rsmereka@future-lab.com

# Initial tcl version. Feb/2004, Rick Smereka
# This version based on code in the book 'Graphical Applications with
# Tcl & Tk' second edition by Eric Foster-Johnson.
proc fontdialog {font_name} {
   # Create a modal font dialog window to select a font.
   # Returns one (1) if user chooses a font, zero (0) otherwise.
   global fd_family fd_style fd_size fd_close
   global fd_strikeout fd_underline
   global fd_name

   set fd_family {}
   set fd_style {}
   set fd_size {}
   set fd_strikeout 0
   set fd_underline 0
   set fd_close -1
   set unsorted_fam [font families]
   set families [lsort $unsorted_fam]
   set fd_name $font_name

   # get current font attributes
   set slant [font actual $font_name -slant]
   set weight [font actual $font_name -weight]

   # default style
   set fd_style "Regular"

   if {$slant == "italic"} {
      if {$weight == "bold"} {
         set fd_style "Bold Italic"
      } else {
         set fd_style "Italic"
      }
   } else {
      if {$weight == "bold"} {
         set fd_style "Bold"
      }
   }

   set family [font actual $font_name -family]
   set fd_family $family
   set size [font actual $font_name -size]
   set fd_size $size
   set strikeout [font actual $font_name -underline]
   set fd_strikeout $strikeout
   set underline [font actual $font_name -overstrike]
   set fd_underline $underline

   # create dialog
   set dlg .fontdialog
   toplevel $dlg
   wm protocol $dlg WM_DELETE_WINDOW "set fd_close 0"
   wm title $dlg "Font Selection"
   label $dlg.family_lbl -text "Font:" -anchor w
   entry $dlg.family_ent -textvariable fd_family \
      -background white
   bind $dlg.family_ent <Key-Return> fontdialogregen
   grid config $dlg.family_lbl -column 0 -row 0 \
      -sticky w
   grid config $dlg.family_ent -column 0 -row 1 \
      -sticky snew

   label $dlg.style_lbl -text "Font Style:" -anchor w
   entry $dlg.style_ent -textvariable fd_style \
      -width 11 -background white
   bind $dlg.style_ent <Key-Return> fontdialogregen
   grid config $dlg.style_lbl -column 1 -row 0 \
      -sticky w
   grid config $dlg.style_ent -column 1 -row 1 \
      -sticky snew

   label $dlg.size_lbl -text "Size:" -anchor w   
   entry $dlg.size_ent -textvariable fd_size \
      -width 4 -background white
   bind $dlg.size_ent <Key-Return> fontdialogregen
   grid config $dlg.size_lbl -column 2 -row 0 \
      -sticky w
   grid config $dlg.size_ent -column 2 -row 1 \
      -sticky snew
   
   # font family listbox
   set fr $dlg.family_list
   frame $fr -bd 0
   listbox $fr.list -height 6 -selectmode single \
      -yscrollcommand "$fr.scroll set" \
      -width 30 -background white

   scrollbar $fr.scroll -command "$fr.list yview"

   foreach f $families {
      $fr.list insert end $f
   }

   bind $fr.list <Button-1> {
      set item [.fontdialog.family_list.list get @%x,%y]
      fontdialogentry $item .fontdialog.family_ent
   }

   pack $fr.scroll -side right -fill y
   pack $fr.list -side left
   grid config $fr -column 0 -row 2 -rowspan 16

   # front style listbox
   set fr $dlg.style_list
   frame $fr -bd 0
   listbox $fr.list -height 6 -selectmode single \
      -yscrollcommand "$fr.scroll set" \
      -width 11 -background white

   scrollbar $fr.scroll -command "$fr.list yview"
   $fr.list insert end "Regular"
   $fr.list insert end "Bold"
   $fr.list insert end "Italic"
   $fr.list insert end "Bold Italic"

   bind $fr.list <Button-1> {
      set item [.fontdialog.style_list.list get @%x,%y]
      fontdialogentry $item .fontdialog.style_ent
   }

   pack $fr.scroll -side right -fill y
   pack $fr.list -side left
   grid config $fr -column 1 -row 2 -rowspan 16

   # font size listbox
   set fr $dlg.size_list
   frame $fr -bd 0
   listbox $fr.list -height 6 -selectmode single \
      -yscrollcommand "$fr.scroll set" \
      -width 4 -background white

   scrollbar $fr.scroll -command "$fr.list yview"
   set i 5

   while {$i <= 36} {
      $fr.list insert end $i
      incr i
   }

   bind $fr.list <Button-1> {
      set item [.fontdialog.size_list.list get @%x,%y]
      fontdialogentry $item .fontdialog.size_ent
   }

   pack $fr.scroll -side right -fill y
   pack $fr.list -side left
   grid config $fr -column 2 -row 2 -rowspan 16

   # ok/cancel
   set fr $dlg.ok_cancel
   frame $fr -bd 0
   button $fr.ok -text "Ok" -command "set fd_close 1"
   button $fr.cancel -text "Cancel" \
      -command "set fd_close 0"
   pack $fr.ok -side top -fill x
   pack $fr.cancel -side top -fill x -pady 2
   grid config $fr -column 4 -row 1 -rowspan 2 \
      -sticky snew -padx 12

   # effects
   set fr $dlg.effects
   frame $fr -bd 3 -relief groove
   label $fr.effects -text "Effects" -anchor w
   checkbutton $fr.strikeout -variable fd_strikeout \
      -text "Strikeout" -anchor w -command fontdialogregen
   checkbutton $fr.underline -variable fd_underline \
      -text "Underline" -anchor w -command fontdialogregen
   pack $fr.effects $fr.strikeout $fr.underline \
      -side top -fill x
   grid config $fr -column 1 -columnspan 2 -row 20 \
      -rowspan 2 -sticky snew -pady 10

   # sample text
   set fr $dlg.sample
   frame $fr -bd 3 -relief groove
   label $fr.1_sample -text "Sample" -anchor w
   label $fr.sample -text  "Every good girl\n does fine." \
      -font $font_name -bd 2 -relief sunken
   pack $fr.1_sample -side top -fill x -pady 4
   pack $fr.sample -side top -pady 4 -ipadx 10 -ipady 10
   grid config $fr -column 0 -columnspan 1 -row 20 \
      -rowspan 2 -sticky snew -pady 10 -padx 2

   focus $dlg
   update

   # make this a modal dialog
   tkwait variable fd_close

   # get rid of dialog and return value
   destroy $dlg

   # restore old font characteristics on cancel
   if {$fd_close == 0} {
      font configure $font_name -family $family \
         -size $size -underline $underline \
         -overstrike $strikeout -slant $slant \
         -weight $weight
   }

   return $fd_close
}

proc fontdialogentry {item entrywidget} {
   # Update one of family, style or size text entries.
   global fd_name

   $entrywidget delete 0 end
   $entrywidget insert end $item

   # regenerate font
   fontdialogregen
}

proc fontdialogregen {} {
   # Regen font from attributes.
   global fd_family fd_style fd_size
   global fd_strikeout fd_underline
   global fd_name

   set weight "normal"

   if {$fd_style == "Bold Italic" || $fd_style == "Bold"} {
      set weight "bold"
   }

   set slant "roman"

   if {$fd_style == "Bold Italic" || $fd_style == "Italic"} {
      set slant "italic"
   }

   # change font to new characteristics
   font configure $fd_name -family $fd_family \
      -size $fd_size -underline $fd_underline \
      -overstrike $fd_strikeout -slant $slant \
      -weight $weight
}
