Smalltick Widgets with Inheritance

UPDATED May 27, 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:

This time demonstrating a color change and the method set.border.relief:

For an implementation see: http://www.xmission.com/~georgeps/implementation/software/Smalltick/

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
 }
''' see pwq: below for comment'''

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
 }

The Container class:

 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]
    return
   }
   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. A method of invoking a recursive destroy of a widget with proper cleanup is needed.

PWQ 21 May 2004, here's the equivalent in straight tcl.

   grid [button .b1 -text {Hello World}] -column 0 -row 0 -sticky news
   grid [button .b2 -text {...Noise} -col ....
   grid [buttin .b3 -text {...Colour} -col .... -command {.b3 configure -bg [tk_chooseColor]}

Three lines instead of 15. Even if we used $win to make it more generic, it would still be shorter, and easier to write, an more importantly we can change the grid to pack or even rearange the widgets quite simply.

My question, where are the examples that show that OO style is more productive than proceedual programming?

NEM 22 May 2004: I think you've missed the point a bit. The value of the OO in this case is in defining the widgets themselves. As I understand it, as well, this isn't just a mega-widget library, but actually allows you to make brand new widgets, which you would usually have to code in C (is that right, George?). Seems pretty cool. Oh, and Tk widgets are objects anyway, at least, they provide an object-like interface - so the whole of the Tk programming world is an example of how OO style is more productive than procedural programming.

One question for GPS: Is the C-layer used in this stuff portable? Can it be used to create native widgets on, say, MacOS X?

GPS: PWQ: Those 3 lines are actually quite a bit more. If you would study the C you'd find a lot more is involved. In this project I've managed to create a thin layer using the base Tk C functions for GCs, fonts, and drawing operations and scripted the widgets in Tcl.

OOP is not a magic bullet. It helps to structure code and make it more flexible. It isn't always more productive. OOP helps generally with larger projects.

NEM: The C layer provided by the gui.so extension (see the csrc directory of the tarball) should be portable. I'm using Tk and a few X functions. The X functions I do use *should be* emulated properly by Tk.

Category GUI

Category Widget