'''UPDATED May 20, 2004'''

[GPS]: This page serves to demonstrate the design behind the [Smalltick] Tk widgets.

For years I've thought about widgets with inheritance for Tcl/Tk.  A couple of weeks ago the ideas hit me, and I realized I might be able to bring these ideas to fruition.

3 Smalltick Button widgets that have inherited from the Widget, Container, and Button classes:
[http://www.xmission.com/~georgeps/Smalltick/Smalltick-2.6-a.png]

This time demonstrating a color change and the method set.border.relief:
[http://www.xmission.com/~georgeps/Smalltick/Smalltick-2.6-b.png]
----
The relevent code from the top down to produce the images above is:
 proc main {} {
  set mw [Widget [new.object]]
  $mw set {window-path .}
 
  set b [Button [new.object] $mw]
  $b -column 0 -row 0 -sticky news -map
  $b -text [list "Hello World"]
 
  set bell [Button [new.object] $mw]
  $bell \
   -text [list "Press me to make some noise!"] \
   -command [list {puts "\a\a"}]
  $bell -column 1 -row 1 -sticky news -map
  
  set col [Button [new.object] $mw]
  $col \
   -text [list "Press me to select a color."] \
   -command [list {$self -bg [tk_chooseColor]}]
  $col -column 0 -row 2 -sticky news -map
 }
----
[GPS]: When I discussed my project in the Tcl'ers Chat [DKF] and others were critical of the idea of using inheritance with widgets.   I've found it hasn't been a problem.

Here is the entire Button class:
 proc Button {b p} {
  Container $b $p
 
  $b set {button-text ""}
 
  $b set [list button-font [gui.create.font "Helvetica 14"]]
  $b set [list button-gc [gui.create.gc [$b get wid]]]
  $b set {button-text ""}
  $b set {button-draw-is-pending 0}
  $b set {command ""}
 
  $b : -command c {
   $self ?set [list command $c]
  }
 
  $b : -text t {
   $self ?set [list button-text $t]
   $self calculate.button.text.size
 
   gui.request.geometry \
    [$self get window-path] \
    [expr {[$self get button-text-width] + 6}] \
    [expr {[$self get button-text-height] + 4}]
 
   $self draw.button.when.idle
  }
 
  $b : button.press.event {} {
   $self set.border.relief pressed
   $self draw.button.when.idle
  }
 
  $b : button.release.event {x y} {
   $self set.border.relief normal
   $self draw.button.when.idle
   eval [$self get command]
  }
 
  $b : calculate.button.text.size {} {
   $self set [list button-text-height \
    [lindex [gui.get.font.metrics [$self get button-font]] end]]
 
   $self set [list button-text-width \
    [gui.measure.string [$self get button-font] [$self get button-text]]]
  }
 
  $b : draw.button {} {
   gui.draw.text \
    [$self get wid] \
    [$self get button-gc] \
    [$self get button-font] \
    3 \
    [$self get button-text-height] \
    [$self get button-text]
   
   $self set {button-draw-is-pending 0}
  }
 
  $b : draw.button.when.idle {} {
   if {[$self get button-draw-is-pending]} return
   $self set {button-draw-is-pending 1}
   after idle [list $self draw.button]
  }
 
  bind Button$b <Expose> [list $b draw.button.when.idle]
  bind Button$b <Configure> [list $b draw.button.when.idle]
  bind Button$b <ButtonPress-1> [list $b button.press.event]
  bind Button$b <ButtonRelease-1> [list $b button.release.event {%x %y}]
 
  bindtags [$b get window-path] [linsert [bindtags [$b get window-path]] end Button$b]
 
  $b calculate.button.text.size
  $b draw.button.when.idle
  
  return $b
 }
----
I've made some changes to the Container class and now it looks like this (in 2.6):
 proc Container {c p} {
  Widget $c
 
  $c set [list window-path \
   [set w [gui.get.unique.window.path [$p get window-path]]]]
 
  set wid [gui.get.window.id [gui.create.window $w]]
 
  $c set [list wid $wid]
 
  #These 3 sets of commands are very alike.  
  #I can't think of the best way to factor them yet.
  $c set [list bg-gc [gui.create.gc $wid]]
  $c set [list bg-color [gui.create.color gray70]]
  gui.set.gc.color [$c get bg-gc] [$c get bg-color]
 
  $c set [list bd-light-gc [gui.create.gc $wid]]
  $c set [list bd-light-color [gui.create.color gray90]]
  gui.set.gc.color [$c get bd-light-gc] [$c get bd-light-color]
 
  $c set [list bd-dark-gc [gui.create.gc $wid]]
  $c set [list bd-dark-color [gui.create.color gray30]]
  gui.set.gc.color [$c get bd-dark-gc] [$c get bd-dark-color]
 
  $c set [list copy-gc [gui.create.gc $wid]]
 
 
  $c set {container-draw-is-pending 0}
  $c set {container-pixmap-width 0}
  $c set {container-pixmap-height 0}
  $c set {container-pixmap 0}
 
  $c set {request-width 100}
  $c set {request-height 100}
 
  $c : -bg color {
   gui.destroy.color [$self get bg-color]
   $self set [list bg-color [gui.create.color $color]]
   gui.set.gc.color [$self get bg-gc] [$self get bg-color]
   $self draw.container.when.idle
  }
 
  $c : -height h {
   $self set [list request-height $h]
   $self request.geometry
  }
 
  $c : -width w {
   $self set [list request-width $w]
   $self request.geometry
  }
 
  $c : build.container.pixmap.if.needed {w h} {
   if {[$self get container-pixmap-width] == $w \
    && [$self get container-pixmap-height] == $h} {
    return 0
   }
   if {0 != [$self get container-pixmap]} {
    gui.destroy.pixmap [$self get container-pixmap]
   }
   $self set [list container-pixmap \
    [gui.create.pixmap [$self get window-path] $w $h]]
   return 1
  }
 
  $c : copy.container.pixmap.to.window {w h} {
   gui.copy.area \
    [$self get copy-gc] \
    [$self get container-pixmap] \
    [$self get wid] \
    0 0 $w $h 0 0
  }
 
  $c : draw.container {} {
   set w [winfo width [$self get window-path]]
   set h [winfo height [$self get window-path]]
 
   if {![$self build.container.pixmap.if.needed [list $w $h]]} {
    $self copy.container.pixmap.to.window [list $w $h]
   }
   gui.draw.rectangle \
    [$self get container-pixmap] \
    [$self get bg-gc] \
    0 0 \
    [winfo width [$self get window-path]] \
    [winfo height [$self get window-path]]
   $self draw.container.border [list [$self get container-pixmap] $w $h]
   $self set {container-draw-is-pending 0}
   $self copy.container.pixmap.to.window [list $w $h]
  }
 
  $c : draw.container.border {pix w h} {
   gui.draw.line \
    $pix \
    [$self get bd-light-gc] \
    0 0 0 $h
   gui.draw.line \
    $pix \
    [$self get bd-light-gc] \
    0 0 $w 0
   gui.draw.line \
    $pix \
    [$self get bd-dark-gc] \
    [expr {$w - 1}] 0 [expr {$w - 1}] $h
   gui.draw.line \
    $pix \
    [$self get bd-dark-gc] \
    0 [expr {$h - 1}] $w [expr {$h - 1}]
  }
 
  $c : draw.container.when.idle {} {
   if {[$self get container-draw-is-pending]} return
   $self set {container-draw-is-pending 1}
   after idle [list $self draw.container]
  }
 
  $c : request.geometry {} {
   gui.request.geometry \
    [$self get window-path] \
    [$self get request-width] \
    [$self get request-height]
  }
 
  $c : set.border.relief type {
   if {"pressed" eq $type} {
    gui.set.gc.color [$self get bd-light-gc] [$self get bd-dark-color]
    gui.set.gc.color [$self get bd-dark-gc] [$self get bd-light-color]
   } else {
    gui.set.gc.color [$self get bd-light-gc] [$self get bd-light-color]
    gui.set.gc.color [$self get bd-dark-gc] [$self get bd-dark-color]
   }
   $self draw.container.when.idle
  }
 
  bind Container$w <Configure> [list $c draw.container.when.idle]
  bind Container$w <Expose> [list $c draw.container.when.idle]
  bindtags $w [list $w Container$w all]
  $c request.geometry
  $c draw.container
 
  return $c
 }
----
You may wonder: why is this cool?  To me it's cool because the widgets are mostly written in Tcl.  The various gui.* commands you see used above are provided by a simple C extension I wrote.  That said, there is work left to do.  The code above is unfinished, because it doesn't provide cleanup for memory allocated, but I felt it was interesting to share the ideas behind this on the Wiki so that people in the chat might discuss it.

----
[Category GUI] | [Category Widget]