home *** CD-ROM | disk | FTP | other *** search
/ PC World 2000 December / PCWorld_2000-12_cd.bin / Komunikace / Comanche / BWidget-1.2 / font.tcl < prev    next >
Text File  |  2000-11-02  |  14KB  |  380 lines
  1. # ------------------------------------------------------------------------------
  2. #  font.tcl
  3. #  This file is part of Unifix BWidget Toolkit
  4. # ------------------------------------------------------------------------------
  5. #  Index of commands:
  6. #     - SelectFont::create
  7. #     - SelectFont::configure
  8. #     - SelectFont::cget
  9. #     - SelectFont::_draw
  10. #     - SelectFont::_destroy
  11. #     - SelectFont::_modstyle
  12. #     - SelectFont::_update
  13. #     - SelectFont::_getfont
  14. #     - SelectFont::_init
  15. # ------------------------------------------------------------------------------
  16.  
  17. namespace eval SelectFont {
  18.     Dialog::use
  19.     LabelFrame::use
  20.     ScrolledWindow::use
  21.  
  22.     Widget::declare SelectFont {
  23.         {-title      String     "Font selection" 0}
  24.         {-parent     String     "" 0}
  25.         {-background TkResource "" 0 frame}
  26.  
  27.         {-type       Enum       dialog        0 {dialog toolbar}}
  28.         {-font       TkResource ""            0 label}
  29.         {-command    String     ""            0}
  30.         {-sampletext String     "Sample Text" 0}
  31.         {-bg         Synonym    -background}
  32.     }
  33.  
  34.     proc ::SelectFont { path args } { return [eval SelectFont::create $path $args] }
  35.     proc use {} {}
  36.  
  37.     variable _families
  38.     variable _styles   {bold italic underline overstrike}
  39.     variable _sizes    {4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24}
  40.  
  41.     variable _widget
  42. }
  43.  
  44.  
  45. # ------------------------------------------------------------------------------
  46. #  Command SelectFont::create
  47. # ------------------------------------------------------------------------------
  48. proc SelectFont::create { path args } {
  49.     variable _families
  50.     variable _sizes
  51.     variable _styles
  52.     variable $path
  53.     upvar 0  $path data
  54.  
  55.     if { ![info exists _families] } {
  56.         loadfont
  57.     }
  58.     Widget::init SelectFont "$path#SelectFont" $args
  59.     set bg [Widget::getoption "$path#SelectFont" -background]
  60.     if { [Widget::getoption "$path#SelectFont" -type] == "dialog" } {
  61.         Dialog::create $path -modal local -default 0 -cancel 1 -background $bg \
  62.             -title  [Widget::getoption "$path#SelectFont" -title] \
  63.             -parent [Widget::getoption "$path#SelectFont" -parent]
  64.  
  65.         set frame [Dialog::getframe $path]
  66.         set topf  [frame $frame.topf -relief flat -borderwidth 0 -background $bg]
  67.  
  68.         set labf1 [LabelFrame::create $topf.labf1 -text "Font" -name font \
  69.                        -side top -anchor w -relief flat -background $bg]
  70.         set sw    [ScrolledWindow::create [LabelFrame::getframe $labf1].sw \
  71.                        -background $bg]
  72.         set lbf   [listbox $sw.lb \
  73.                        -height 5 -width 25 -exportselection false -selectmode browse]
  74.         ScrolledWindow::setwidget $sw $lbf
  75.         LabelFrame::configure $labf1 -focus $lbf
  76.         eval $lbf insert end $_families
  77.         set script "set SelectFont::$path\(family\) \[%W curselection\]; SelectFont::_update $path"
  78.         bind $lbf <ButtonRelease-1> $script
  79.         bind $lbf <space>           $script
  80.         pack $sw -fill both -expand yes
  81.  
  82.         set labf2 [LabelFrame::create $topf.labf2 -text "Size" -name size \
  83.                        -side top -anchor w -relief flat -background $bg]
  84.         set sw    [ScrolledWindow::create [LabelFrame::getframe $labf2].sw \
  85.                        -scrollbar vertical -background $bg]
  86.         set lbs   [listbox $sw.lb \
  87.                        -height 5 -width 6 -exportselection false -selectmode browse]
  88.         ScrolledWindow::setwidget $sw $lbs
  89.         LabelFrame::configure $labf2 -focus $lbs
  90.         eval $lbs insert end $_sizes
  91.         set script "set SelectFont::$path\(size\) \[%W curselection\]; SelectFont::_update $path"
  92.         bind $lbs <ButtonRelease-1> $script
  93.         bind $lbs <space>           $script
  94.         pack $sw -fill both -expand yes
  95.  
  96.         set labf3 [LabelFrame::create $topf.labf3 -text "Style" -name style \
  97.                        -side top -anchor w -relief sunken -bd 1 -background $bg]
  98.         set subf  [LabelFrame::getframe $labf3]
  99.         foreach st $_styles {
  100.             set name [lindex [BWidget::getname $st] 0]
  101.             if { $name == "" } {
  102.                 set name "[string toupper [string index $name 0]][string range $name 1 end]"
  103.             }
  104.             checkbutton $subf.$st -text $name \
  105.                 -variable   SelectFont::$path\($st\) \
  106.                 -background $bg \
  107.                 -command    "SelectFont::_update $path"
  108.             bind $subf.$st <Return> break
  109.             pack $subf.$st -anchor w
  110.         }
  111.         LabelFrame::configure $labf3 -focus $subf.[lindex $_styles 0]
  112.  
  113.         pack $labf1 -side left -anchor n -fill both -expand yes
  114.         pack $labf2 -side left -anchor n -fill both -expand yes -padx 8
  115.         pack $labf3 -side left -anchor n -fill both -expand yes
  116.  
  117.         set botf [frame $frame.botf -width 100 -height 50 \
  118.                       -bg white -bd 0 -relief flat \
  119.                       -highlightthickness 1 -takefocus 0 \
  120.                       -highlightbackground black \
  121.                       -highlightcolor black]
  122.  
  123.         set lab  [label $botf.label \
  124.                       -background white -foreground black \
  125.                       -borderwidth 0 -takefocus 0 -highlightthickness 0 \
  126.                       -text [Widget::getoption "$path#SelectFont" -sampletext]]
  127.         place $lab -relx 0.5 -rely 0.5 -anchor c
  128.  
  129.         pack $topf -pady 4 -fill both -expand yes
  130.         pack $botf -pady 4 -fill x
  131.  
  132.         Dialog::add $path -name ok
  133.         Dialog::add $path -name cancel
  134.  
  135.         set data(label) $lab
  136.         set data(lbf)   $lbf
  137.         set data(lbs)   $lbs
  138.  
  139.         _getfont $path
  140.  
  141.         proc ::$path { cmd args } "return \[eval SelectFont::\$cmd $path \$args\]"
  142.  
  143.         return [_draw $path]
  144.     } else {
  145.         frame $path -relief flat -borderwidth 0 -background $bg
  146.         bind $path <Destroy> "SelectFont::_destroy $path"
  147.         set lbf [ComboBox::create $path.font \
  148.                      -highlightthickness 0 -takefocus 0 -background $bg \
  149.                      -values   $_families \
  150.                      -textvariable SelectFont::$path\(family\) \
  151.                      -editable 0 \
  152.                      -modifycmd "SelectFont::_update $path"]
  153.         set lbs [ComboBox::create $path.size \
  154.                      -highlightthickness 0 -takefocus 0 -background $bg \
  155.                      -width    4 \
  156.                      -values   $_sizes \
  157.                      -textvariable SelectFont::$path\(size\) \
  158.                      -editable 0 \
  159.                      -modifycmd "SelectFont::_update $path"]
  160.         pack $lbf -side left -anchor w
  161.         pack $lbs -side left -anchor w -padx 4
  162.         foreach st $_styles {
  163.             button $path.$st \
  164.                 -highlightthickness 0 -takefocus 0 -padx 0 -pady 0 -bd 2 \
  165.                 -background $bg \
  166.                 -image  [Bitmap::get $st] \
  167.                 -command "SelectFont::_modstyle $path $st"
  168.             pack $path.$st -side left -anchor w
  169.         }
  170.         set data(label) ""
  171.         set data(lbf)   $lbf
  172.         set data(lbs)   $lbs
  173.         _getfont $path
  174.  
  175.         rename $path ::$path:cmd
  176.         proc ::$path { cmd args } "return \[eval SelectFont::\$cmd $path \$args\]"
  177.     }
  178.  
  179.     return $path
  180. }
  181.  
  182.  
  183. # ------------------------------------------------------------------------------
  184. #  Command SelectFont::configure
  185. # ------------------------------------------------------------------------------
  186. proc SelectFont::configure { path args } {
  187.     variable _styles
  188.  
  189.     set res [Widget::configure "$path#SelectFont" $args]
  190.  
  191.     if { [Widget::hasChanged "$path#SelectFont" -font font] } {
  192.         _getfont $path
  193.     }
  194.     if { [Widget::hasChanged "$path#SelectFont" -background bg] } {
  195.         switch -- [Widget::getoption "$path#SelectFont" -type] {
  196.             dialog {
  197.                 Dialog::configure $path -background $bg
  198.                 set topf [Dialog::getframe $path].topf
  199.                 $topf configure -background $bg
  200.                 foreach labf {labf1 labf2} {
  201.                     LabelFrame::configure $topf.$labf -background $bg
  202.                     set subf [LabelFrame::getframe $topf.$labf]
  203.                     ScrolledWindow::configure $subf.sw -background $bg
  204.                     $subf.sw.lb configure -background $bg
  205.                 }
  206.                 LabelFrame::configure $topf.labf3 -background $bg
  207.                 set subf [LabelFrame::getframe $topf.labf3]
  208.                 foreach w [winfo children $subf] {
  209.                     $w configure -background $bg
  210.                 }
  211.             }
  212.             toolbar {
  213.                 $path configure -background $bg
  214.                 ComboBox::configure $path.font -background $bg
  215.                 ComboBox::configure $path.size -background $bg
  216.                 foreach st $_styles {
  217.                     $path.$st configure -background $bg
  218.                 }
  219.             }
  220.         }
  221.     }
  222.     return $res
  223. }
  224.  
  225.  
  226. # ------------------------------------------------------------------------------
  227. #  Command SelectFont::cget
  228. # ------------------------------------------------------------------------------
  229. proc SelectFont::cget { path option } {
  230.     return [Widget::cget "$path#SelectFont" $option]
  231. }
  232.  
  233.  
  234. # ------------------------------------------------------------------------------
  235. #  Command SelectFont::loadfont
  236. # ------------------------------------------------------------------------------
  237. proc SelectFont::loadfont { } {
  238.     variable _families
  239.  
  240.     # initialize families
  241.     set _families {}
  242.     set lfont     [font families]
  243.     lappend lfont times courier helvetica
  244.     foreach font $lfont {
  245.         set family [font actual [list $font] -family]
  246.         if { [lsearch -exact $_families $family] == -1 } {
  247.             lappend _families $family
  248.         }
  249.     }
  250.     set _families [lsort $_families]
  251. }
  252.  
  253.  
  254. # ------------------------------------------------------------------------------
  255. #  Command SelectFont::_draw
  256. # ------------------------------------------------------------------------------
  257. proc SelectFont::_draw { path } {
  258.     variable $path
  259.     upvar 0  $path data
  260.  
  261.     $data(lbf) selection clear 0 end
  262.     $data(lbf) selection set $data(family)
  263.     $data(lbf) activate $data(family)
  264.     $data(lbf) see $data(family)
  265.     $data(lbs) selection clear 0 end
  266.     $data(lbs) selection set $data(size)
  267.     $data(lbs) activate $data(size)
  268.     $data(lbs) see $data(size)
  269.     _update $path
  270.  
  271.     if { [Dialog::draw $path] == 0 } {
  272.         set result [Widget::getoption "$path#SelectFont" -font]
  273.     } else {
  274.         set result ""
  275.     }
  276.     unset data
  277.     Widget::destroy "$path#SelectFont"
  278.     destroy $path
  279.     return $result
  280. }
  281.  
  282.  
  283. # ------------------------------------------------------------------------------
  284. #  Command SelectFont::_destroy
  285. # ------------------------------------------------------------------------------
  286. proc SelectFont::_destroy { path } {
  287.     variable $path
  288.     upvar 0  $path data
  289.  
  290.     unset data
  291.     Widget::destroy "$path#SelectFont"
  292.     rename $path {}
  293. }
  294.  
  295.  
  296. # ------------------------------------------------------------------------------
  297. #  Command SelectFont::_modstyle
  298. # ------------------------------------------------------------------------------
  299. proc SelectFont::_modstyle { path style } {
  300.     variable $path
  301.     upvar 0  $path data
  302.  
  303.     if { $data($style) == 1 } {
  304.         $path.$style configure -relief raised
  305.         set data($style) 0
  306.     } else {
  307.         $path.$style configure -relief sunken
  308.         set data($style) 1
  309.     }
  310.     _update $path
  311. }
  312.  
  313.  
  314. # ------------------------------------------------------------------------------
  315. #  Command SelectFont::_update
  316. # ------------------------------------------------------------------------------
  317. proc SelectFont::_update { path } {
  318.     variable _families
  319.     variable _sizes
  320.     variable _styles
  321.     variable $path
  322.     upvar 0  $path data
  323.  
  324.     set type [Widget::getoption "$path#SelectFont" -type]
  325.     if { $type == "dialog" } {
  326.         set curs [$path:cmd cget -cursor]
  327.         $path:cmd configure -cursor watch
  328.     }
  329.     if { [Widget::getoption "$path#SelectFont" -type] == "dialog" } {
  330.         set font [list \
  331.                       [lindex $_families $data(family)] \
  332.                       [lindex $_sizes $data(size)]]
  333.     } else {
  334.         set font [list $data(family) $data(size)]
  335.     }
  336.     foreach st $_styles {
  337.         if { $data($st) } {
  338.             lappend font $st
  339.         }
  340.     }
  341.     Widget::setoption "$path#SelectFont" -font $font
  342.     if { $type == "dialog" } {
  343.         $data(label) configure -font $font
  344.         $path:cmd configure -cursor $curs
  345.     } elseif { [set cmd [Widget::getoption "$path#SelectFont" -command]] != "" } {
  346.         uplevel \#0 $cmd
  347.     }
  348. }
  349.  
  350.  
  351. # ------------------------------------------------------------------------------
  352. #  Command SelectFont::_getfont
  353. # ------------------------------------------------------------------------------
  354. proc SelectFont::_getfont { path } {
  355.     variable _families
  356.     variable _styles
  357.     variable _sizes
  358.     variable $path
  359.     upvar 0  $path data
  360.  
  361.     array set font [font actual [Widget::getoption "$path#SelectFont" -font]]
  362.     set data(bold)       [expr {[string compare $font(-weight) "normal"] != 0}]
  363.     set data(italic)     [expr {[string compare $font(-slant)  "roman"]  != 0}]
  364.     set data(underline)  $font(-underline)
  365.     set data(overstrike) $font(-overstrike)
  366.     if { [Widget::getoption "$path#SelectFont" -type] == "dialog" } {
  367.         set idxf [lsearch $_families $font(-family)]
  368.         set idxs [lsearch $_sizes    $font(-size)]
  369.         set data(family) [expr {$idxf >= 0 ? $idxf : 0}]
  370.         set data(size)   [expr {$idxs >= 0 ? $idxs : 0}]
  371.     } else {
  372.         set data(family) $font(-family)
  373.         set data(size)   $font(-size)
  374.         foreach st $_styles {
  375.             $path.$st configure -relief [expr {$data($st) ? "sunken":"raised"}]
  376.         }
  377.     }
  378. }
  379.  
  380.