"Fossies" - the Fresh Open Source Software Archive

Member "Pansophica-src-1.3/BAF_modules/tcl/src/NVR_BWidgets/demo/basic.tcl" (10 Apr 2007, 6968 Bytes) of package /linux/www/old/Pansophica-src-1.3-1.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Tcl/Tk source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file.

    1 
    2 namespace eval DemoBasic {
    3     variable var
    4     variable count 0
    5     variable id    ""
    6 }
    7 
    8 
    9 proc DemoBasic::create { nb } {
   10     set frame [$nb insert end demoBasic -text "Basic"]
   11 
   12     set topf  [frame $frame.topf]
   13     set titf1 [TitleFrame $topf.titf1 -text "Label"]
   14     set titf2 [TitleFrame $topf.titf2 -text "Entry"]
   15     set titf3 [TitleFrame $frame.titf3 -text "Button and ArrowButton"]
   16 
   17     _label  [$titf1 getframe]
   18     _entry  [$titf2 getframe]
   19     _button [$titf3 getframe]
   20 
   21     pack $titf1 $titf2 -side left -fill both -padx 4 -expand yes
   22     pack $topf -pady 2 -fill x
   23     pack $titf3 -pady 2 -padx 4 -fill x
   24 
   25     return $frame
   26 }
   27 
   28 
   29 proc DemoBasic::_label { parent } {
   30     variable var
   31 
   32     set lab [Label $parent.label -text "This is a Label widget" \
   33                  -helptext "Label widget"]
   34     set chk [checkbutton $parent.chk -text "Disabled" \
   35                  -variable DemoBasic::var($lab,-state) \
   36                  -onvalue  disabled -offvalue normal \
   37                  -command  "$lab configure -state \$DemoBasic::var($lab,-state)"]
   38     pack $lab -anchor w -pady 4
   39     pack $chk -anchor w
   40 }
   41 
   42 
   43 proc DemoBasic::_entry { parent } {
   44     set ent  [Entry $parent.entry -text "Press enter" \
   45                   -command  {set DemoBasic::var(entcmd) "-command called"; after 500 {set DemoBasic::var(entcmd) ""}} \
   46                    -helptext "Entry widget"]
   47     set chk1 [checkbutton $parent.chk1 -text "Disabled" \
   48                   -variable DemoBasic::var($ent,state) \
   49                   -onvalue  disabled -offvalue normal \
   50                   -command  "$ent configure -state \$DemoBasic::var($ent,state)"]
   51     set chk2 [checkbutton $parent.chk2 -text "Non editable" \
   52                   -variable DemoBasic::var($ent,editable) \
   53                   -onvalue  false -offvalue true \
   54                   -command  "$ent configure -editable \$DemoBasic::var($ent,editable)"]
   55     set lab  [label $parent.cmd -textvariable DemoBasic::var(entcmd) -foreground red]
   56     pack $ent -pady 4 -anchor w
   57     pack $chk1 $chk2 -anchor w
   58     pack $lab -pady 4
   59 }
   60 
   61 
   62 proc DemoBasic::_button { parent } {
   63     variable var
   64 
   65     set frame [frame $parent.butfr]
   66     set but   [Button $frame.but -text "Press me!" \
   67                    -repeatdelay 300 \
   68                    -command  "DemoBasic::_butcmd command" \
   69                    -helptext "This is a Button widget"]
   70     set sep1  [Separator $frame.sep1 -orient vertical]
   71     set arr1  [ArrowButton $frame.arr1 -type button \
   72                    -width 25 -height 25 \
   73                    -repeatdelay 300 \
   74                    -command  "DemoBasic::_butcmd command" \
   75                    -helptext "This is an ArrowButton widget\nof type button"]
   76     set sep2  [Separator $frame.sep2 -orient vertical]
   77     set arr2  [ArrowButton $frame.arr2 -type arrow \
   78                    -width 25 -height 25 -relief sunken -ipadx 0 -ipady 0 \
   79                    -repeatdelay 300 \
   80                    -command  "DemoBasic::_butcmd command" \
   81                    -helptext "This is an ArrowButton widget\nof type arrow"]
   82 
   83     pack $but  -side left -padx 4
   84     pack $sep1 -side left -padx 4 -fill y
   85     pack $arr1 -side left -padx 4
   86     pack $sep2 -side left -padx 4 -fill y
   87     pack $arr2 -side left -padx 4
   88     pack $frame
   89 
   90     set sep3  [Separator $parent.sep3 -orient horizontal]
   91     pack $sep3 -fill x -pady 10
   92 
   93     set labf1 [LabelFrame $parent.labf1 -text "Command" -side top \
   94                    -anchor w -relief sunken -borderwidth 1]
   95     set subf  [$labf1 getframe]
   96     set chk1  [checkbutton $subf.chk1 -text "Disabled" \
   97                    -variable DemoBasic::var(bstate) -onvalue disabled -offvalue normal \
   98                    -command  "DemoBasic::_bstate \$DemoBasic::var(bstate) $but $arr1 $arr2"]
   99     set chk2  [checkbutton $subf.chk2 -text "Use -armcommand/\n-disarmcommand" \
  100                    -justify left \
  101                    -variable DemoBasic::var(barmcmd) \
  102                    -command  "DemoBasic::_barmcmd \$DemoBasic::var(barmcmd) $but $arr1 $arr2"]
  103     pack $chk1 $chk2 -anchor w
  104 
  105     set label [label $parent.label -textvariable DemoBasic::var(butcmd) -foreground red]
  106     pack $label -side bottom -pady 4
  107 
  108     set labf2 [LabelFrame $parent.labf2 -text "Direction" -side top \
  109                    -anchor w -relief sunken -borderwidth 1]
  110     set subf  [$labf2 getframe]
  111     set var(bside) top
  112     foreach dir {top left bottom right} {
  113         set rad [radiobutton $subf.$dir -text "$dir arrow" \
  114                      -variable DemoBasic::var(bside) -value $dir \
  115                      -command  "DemoBasic::_bside \$DemoBasic::var(bside) $arr1 $arr2"]
  116         pack $rad -anchor w
  117     }
  118 
  119     set labf3 [LabelFrame $parent.labf3 -text "Relief" -side top \
  120                    -anchor w -relief sunken -borderwidth 1]
  121     set subf  [$labf3 getframe]
  122     set var(brelief) raised
  123     foreach {f lrelief} {f1 {raised sunken ridge groove} f2 {flat solid link}} {
  124         set f [frame $subf.$f]
  125         foreach relief $lrelief {
  126             set rad [radiobutton $f.$relief -text $relief \
  127                          -variable DemoBasic::var(brelief) -value $relief \
  128                          -command  "DemoBasic::_brelief \$DemoBasic::var(brelief) $but $arr1 $arr2"]
  129             pack $rad -anchor w
  130         }
  131         pack $f -side left -padx 2 -anchor n
  132     }
  133     pack $labf1 $labf2 $labf3 -side left -fill y -padx 4
  134 }
  135 
  136 
  137 proc DemoBasic::_bstate { state but arr1 arr2 } {
  138     foreach but [list $but $arr1 $arr2] {
  139         $but configure -state $state
  140     }
  141 }
  142 
  143 
  144 proc DemoBasic::_brelief { relief but arr1 arr2 } {
  145     $but configure -relief $relief
  146     if { $relief != "link" } {
  147         foreach arr [list $arr1 $arr2] {
  148             $arr configure -relief $relief
  149         }
  150     }
  151 }
  152 
  153 
  154 proc DemoBasic::_bside { side args } {
  155     foreach arr $args {
  156         $arr configure -dir $side
  157     }
  158 }
  159 
  160 
  161 proc DemoBasic::_barmcmd { value but arr1 arr2 } {
  162     if { $value } {
  163         $but configure \
  164             -armcommand    "DemoBasic::_butcmd arm" \
  165             -disarmcommand "DemoBasic::_butcmd disarm" \
  166             -command {}
  167         foreach arr [list $arr1 $arr2] {
  168             $arr configure \
  169                 -armcommand    "DemoBasic::_butcmd arm" \
  170                 -disarmcommand "DemoBasic::_butcmd disarm" \
  171                 -command {}
  172         }
  173     } else {
  174         $but configure -armcommand {} -disarmcommand {} \
  175             -command  "DemoBasic::_butcmd command"
  176         foreach arr [list $arr1 $arr2] {
  177             $arr configure -armcommand {} -disarmcommand {} \
  178                 -command "DemoBasic::_butcmd command"
  179         }
  180     }
  181 }
  182 
  183 
  184 proc DemoBasic::_butcmd { reason } {
  185     variable count
  186     variable id
  187 
  188     catch {after cancel $id}
  189     if { $reason == "arm" } {
  190         incr count
  191         set DemoBasic::var(butcmd) "$reason command called ($count)"
  192     } else {
  193         set count 0
  194         set DemoBasic::var(butcmd) "$reason command called"
  195     }
  196     set id [after 500 {set DemoBasic::var(butcmd) ""}]
  197 }
  198 
  199